Personal tools
You are here: Home Projects SETL LITTLE Source code SYN: Syntax generator for the LITTLE system. By Edith Deak and David Shields.
Document Actions

SYN: Syntax generator for the LITTLE system. By Edith Deak and David Shields.

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

SYN: Syntax generator for the LITTLE system. By Edith Deak and David Shields.

       1 .=member intro
       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                 syntax generator for the little system
      28
      29
      30                                   by
      31
      32                               edith deak
      33                             david shields
      34
      35
      36              direct inquiries, comments and criticisms to
      37
      38                       little project coordinator
      39                      computer science department
      40               courant institute of mathematical sciences
      41                           251 mercer street
      42                       new york, new york  10012
      43                                u. s. a.
      44
      45
      46
      47 this program translates an annotated bnf-like description of a
      48 programming language grammar into tables and text fragments
      49 which form the central part of a parser for the language which
      50 consists of an interpreter for an abstract parsing machine.
      51
      52 */
       1 .=member mods
       2 $ --- all mods are to include self description after mods.2 ---
dsk    2
dsk    3 $    dsk       d. shields          15-dec-81           level 81349
dsk    4 $
dsk    5 $    1.  fix filename length for s32 and s47.
dsk    6 $    2.  make program parameter 'synbin=0/synbin' for all machines.
dsk    7 $        thus by default synbin file written only if name given. this
dsk    8 $        file not needed by any current production compiler using
dsk    9 $        syn and generally needed only during bootstrap.
dsk   10
utsa   1
utsa   2 $    utsa      d. shields          29-nov-81           level 81333
utsa   3 $
utsa   4 $    support s47: amdahl uts (universal timesharing system).
utsa   5 $    this implementation runs on s37 architecture using an operating
utsa   6 $    system very close to unix (v7), and uses the ascii character set.
utsa   7
dsj    1
dsj    2 $    dsj       d. shields          08-sep-81           level 81251
dsj    3 $
dsj    4 $    for s37, change default name for synout file to 'synout' and
dsj    5 $    change line length for synout file from 72 to 80. this is helpful
dsj    6 $    for s37 and causes no harm in other systems.
dsj    7 $    deck affected - synini
dsj    8
dsi    1
dsi    2 $    dsi       d. shields          03-sep-80           level 80247
dsi    3 $
dsi    4 $    1.  fix problem (fr153) for s37 in that some initial asm macros
dsi    5 $        had extraneous bits set.
dsi    6 $    2.  make record length of asm file 80. this needed for s37, and
dsi    7 $        causes no harm for other implementations.
dsi    8 $    3.  permit bin and asm files to be named with 'synbin=/' and
dsi    9 $        'synasm=/' respectively. this maintains compatibility with
dsi   10 $        prior practice. for s37, defaults are 'synasm=assemble/'
dsi   11 $        and 'synbin=synbin/'.
dsi   12 $    decks affected - start, synini, ptasm.
dsi   13
dsh    1
dsh    2 $    dsh       d. shields          30-jun-80           level 80182
dsh    3 $
dsh    4 $    add new feature for setl. if setl option and implicit macros
dsh    5 $    used, then report number of implicit entries. for example,
dsh    6 $    generate macro for -impmax- if im=p selected.
dsh    7 $    deck affected - ptout.
dsh    8
dsg    1
dsg    2 $    dsg       d. shields          05-may-79           level 79127
dsg    3 $    correct to generate 'search pt10' and not 'universal pt10' for
dsg    4 $    s10, and also add code for pt10 macros to s10.
dsg    5 $    decks affected - ptasm, pt10.
dsg    6
dsf    1
dsf    2 $    dsf       d. shields          13-apr-79           level 79103
dsf    3 $
dsf    4 $    a problem in using syn is that large grammars, notably setl,
dsf    5 $    require parse tables which are so large that the data
dsf    6 $    statements to initialize them cannot be compiled by the
dsf    7 $    little compiler.  prior practice has been to read in the
dsf    8 $    parse table from a file.  this correction adds option
dsf    9 $    asm= to direct syn to write assembler macro calls to unit 6
dsf   10 $    so that required data statements can be assembled by
dsf   11 $    machine assembler.  this done in new procedure ptasm.
dsf   12 $    macro definitions provided in new decks pt10, pt32, pt37 and pt66.
dsf   13 $    decks affected - start, synini, ptout; new decks ptasm, pt10
dsf   14 $        pt32, pt37 and pt66.
dsf   15
dse    1 $ dse  d. shields  26-mar-79  79085  - fix bugs in setl option.
dsd    1
dsd    2 $    dsd       d. shields          19 feb 79           level 79050
dsd    3 $
dsd    4 $    add feature if setl option enabled to write out location
dsd    5 $    of definer for  symbol.
dsd    6 $    decks affected - start, synini, gnam, ptout.
dsd    7
dsc    1
dsc    2 $    dsc       d. shields          06 feb 79           level 79037
dsc    3 $
dsc    4 $    add program option 'setl=0/1' to support setl system.
dsc    5 $    this involves generation of two additional members and
dsc    6 $    writing of parse table in binary form to unit 5.
dsc    7 $    decks affected - start, synini, res4, ptout.
dsc    8
vax    1
vax    2 $    vax       d. shields          21 nov  78          level 78325
vax    3 $              r. kenner
vax    4 $
vax    5 $    add configuration values for s32: dec vax-11/780.
vax    6 $    decks affected - macros, start, synini, nextok.
vax    7
       3
       4 $    rbkc      r. kenner           01 mar 78           level 78060
       5 $
       6 $    1.  correct miscellaneous bugs detected on porting to s37.
       7 $    2.  insert conditional code for s10.
       8 $    3.  delete unused token types and add sstok.
       9 $    decks affected - macros, start, synini, nextok, res4, putmem,
      10 $                     synexit
      11
      12
      13 $    rbkb      r. kenner           17 feb 78
      14 $
      15 $    fix error in little grammar causing miscompilations of
      16 $    certain nested assignments and extractors.  this
      17 $    update goes with mod rbkm in gen.
      18 $    deck affected - ltlgrmr
      19
      20
      21 $    dsb       d. shields          17 oct 77           level 77290.
      22 $
      23 $    add implicit macros to assist in encodings needed in grammar.
      24 $    an implicit macro is a name which begins with a letter followed
      25 $    by the break (underline) character, where the letter is
      26 $    among those selected by the -im- program parameter.
      27 $    each such group of names is assigned an integer code, starting
      28 $    from one, in the order the names occur.  the names are replaced
      29 $    by the code, so that implicit macro names can occur where syn
      30 $    accepts, or requires, an integer to appear. syn reports the
      31 $    codes assigned for implicit macro with code -l- by writing
      32 $    a member -syniml-.  there can be up to four implicit macro groups.
      33 $    implicit macros can be used to name group of constants used
      34 $    by user-defined opcode, to name error messages, etc.
      35 $    decks affected - start, nextok, ptout, listha.
      36
      37
      38 $    rbka      r. kenner           14 oct 77
      39 $
      40 $    revise little grammar according to mod rbkj in gen.
      41 $    deck affected - ltlgrmr (resequenced).
      42
      43
      44 $    dsa       d. shields          03 oct 77           level 77276.
      45 $
      46 $    fix reported bug in handling of errors in grammar.
      47 $    deck affected - parse
      48
      49
      50 $    (none)    d. shields          08 aug 77           77220.
      51 $
      52 $    release as version 1.0 of syn.  show form of mod notice.
      53
       1 .=member macros
       2
       3      +*  synlevel =  $ date of last program change.
dsk   11          'syn(81349)'  $ 15-dec-81
       5          **
       6
       7      $   q3 and macdef are used to define macros in macros. macdrop
       8      $   releases macro from macro status
       9
      10        +*  q3(a,b,c) = a b c  **
      11        +*  macdef(text) = q3(+,*text*,*)  **
      12        +*  macdrop(mname) = macdef(mname=)  **
      13
      14      +*  defc(nam) =    $ define constant identifier
      15          macdef(nam = zzyz) **
      16
      17      +*  locofer = parseerrloc **
      18      +*  pt_dim = parsearamax **
      19
      20 $ syn run on    thu  28 jul 77  11:00:00
      21      +*  parsearamax =  178 **
      22      +*  parselitaramax =  0 **
      23      +*  parselexaramax =  0 **
      24      +*  parseactmax =  23 **
      25      +*  parseerrloc =  167 **
      26      +*  parseerrmax =  24 **
      27 $ end member synmac
      28
      29      $   target machine parameters
      30      +*  ws = .ws. **  $ machine word size.
      31      +*  ps = .ps. **  $ machine pointer (address) size.
      32      +*  cs = .cs. **  $ machine character size.
      33      +*  cpw = (ws/cs) **  $ characters per machine word
      34
      35
      36      +*  wpc = $ number of words in line image
      37 .+s66    09
vax    9 .+s32    20  $ 80 columns
      38 .+s37    20  $ 80 columns
utsa   8 .+s47    20  $ 80 columns
mgfa   1 .+s10    20
      40          **
      41
      42      +*  blankword =  $ word of blank chars (see insnam).
vax   10 .+s32    4r
      43 .+s37    4r
utsa   9 .+s47    4r
      44 .+s66    10r
mgfa   2 .+s10    4r
      46          **
      47
      48      $   macros related to file names
      49      +*  filenamelen = 20 ** $ max. length of file name in chars.
dsk   12 .+s32 +*  filenamelen = 64 ** $ max. length of file name in chars.
dsk   13 .+s47 +*  filenamelen = 64 ** $ max. length of file name in chars.
utsa  10 .+s32  +* filenamelen = 64 **
utsa  11 .+s47  +* filenamelen = 64 **
      50      +*  lctimelen = 30  **  $ length of lctime time representation.
      51
      52      +*  tokenfile = 3 **    $ token file number.
      53
      54      +*  parsefile = 4 **      $ voa file number.
      55
      56      $   io access codes.
      57      +*  access_read    = 4 **
      58
      59
      60      $   macros for listing generation (procedures in run-time library)
      61
      62      +*  listl(n)   = call contlpr(26,n);**  $ set listing flag
      63      +*  terml(n)   = call contlpr(27,n);**  $ set terminal flag
      64      $   if less than n lines remain on current page.
      65
      66      +*  digofchar(c) =  $ value of character digit.
      67          (c-1r0)   $ use if codes for numbers in order.
      68          **
      69      +*  charofdig(c) = $ maps digit into character code
      70          (c+1r0)  $ use if codes for numbers in order.
      71          **
      72
      73
      74      +*  hexcharofdig(c) = .ch. (c)+1, '0123456789abcdef' **
      75
      76      $   countup macro for incrementing and testing variable
      77      +*  countup(var,lim,msg) =
      78          var = var+1;
      79          if (var>lim) call gtoflo(var,lim); **
      80
      81      +*  alphabet = 'abcdefghijklmnopqrstuvwxyz' **
      82
      83
      84      $   yes and no macros used for logical expressions to clarify
      85      $   logical intent.
      86      +*  yes = 1 **  +* no = 0 **
      87
      88      +*  toklenmax = 60 **  $ maximum length of token in characters
      89
      90
      91
      92      $   macros related to parser and lexical token processing
      93
      94
      95      $   (codes must agree with those assigned by lex phase.)
      96      $   the codes used in token reader procedure -nextok-
      97      $   codes for lexical types assigned in lexical scan
      98      +*  toktypes = 14 ** $ no. of token types below
      99      +*  nametok  = 1 **  $  name
     100      +*  spectok  = 2 **  $  special token, e.g. (
     101      +*  pdotok   = 3 **  $  type of period delimited operators
     102      +*  dectok   = 4 **  $  type of decimal integers, e.g. 100
     103      +*  sstok    = 5 **  $ s-type strings
     104      +*  strtok   = 6 **
     105      +*  bittok = 8 **
     106      +*  qstok    = 9 **   $ q type string constant
     107      +*  rztok    = 12 **       $ right-zero type string constant (r)
     108      +*  realtok  = 14 **    $ real token
     109      +*  listcontroltok = 27 **  $ '.=list' directive.
     110      +*  listejecttok = 28 **  $ '.=eject' list directive.
     111      +*  listtitletok = 29 **  $ '.=title' directive.
     112      +*  tokrline = 30 **  $ code for line image
     113      +*  tokreof  = 31 **  $ code for end-token-file
     114
     115 .+s66.
     116      +*  tokrtyp  = .f. 1, 5, **  $ token type (lex type or code)
     117      +*  tokrlen  = .f. 7, 7, **  $ length of token in chars
     118      +*  tokrlc   = .f. 14, 9, **  $ token literal code
     119 .-s66.
     120      +*  tokrtyp  = .f.  1, 8, **
     121      +*  tokrlen  = .f.  9, 8, **
     122      +*  tokrlc   = .f. 17, 8, **
     123 ..s66
     124
     125      +*  tokrval  =  $ first few characters of short token.
     126 .+s66    .f. 25, 36,
vax   11 .+s32    .f. 25, 8,
     127 .+s37    .f. 25, 8,
utsa  12 .+s47    .f. 25, 8,
mgfa   3 .+s10    .f. 28, 9,
     129         **
     130      +*  cpstr =  $ character per short token record
     131 .+s66    6
vax   12 .+s32    1
     132 .+s37    1
utsa  13 .+s47    1
mgfa   4 .+s10    1
     134          **
     135
     136      +*  naml(hap) =   $ print name of ha item
     137          call sdsnamr(hap);
     138          put :sdsnamstr,a;  **  $ sdsnamr puts charstring in
     139                       $ sdsnamstr
     140
     141
     142 $ p a r s e   t a b l e   o p c o d e s
     143
     144 $ the following opcodes comprise the operations of the
     145 $ parse interpreter.  these drive the interpreter in this
     146 $ program, and are also the opcodes of the parse table
     147 $ generated by this program
     148
     149      defc(op_act)  $ perform action.
     150      defc(op_bak)  $ restore parse.
     151      defc(op_err)  $ report error if failure.
     152      defc(op_jif)  $ jump if failure.
     153      defc(op_jmp)  $ jump.
     154      defc(op_lex)  $ test for token of given lexical type.
     155      defc(op_lit)  $ test for literal.
     156      defc(op_set)  $ set parse register.
     157      defc(op_sev)  $ seek zero or more instances of subpart.
     158      defc(op_sub)  $ seek subpart.
     159      defc(op_op1)  $ user operation 1.
     160      defc(op_op2)  $ user operation 2.
     161      defc(op_op3)  $ user operation 3.
     162      defc(op_op4)  $ user operation 4.
     163      defc(op_op5)  $ user operation 5.
     164
     165 .=zzyorg z     $ reset zzyz to origin
     166
     167      +*  op_max = op_op5 **  $ maximum valid operator value.
     168
     169 $ l e x i c a l   c o d e s
     170
     171 $ lexical codes for the lexical classes of the self-defining
     172 $ grammar which drives this program.
     173
     174      defc(lexc_name)
     175      defc(lexc_string)     $ quoted string
     176      defc(lexc_int)        $ integer
     177      defc(lexc_nonslash)    $ not a slash '/'
     178      defc(lexc_noneq)    $ not an arrow '='
     179      defc(lexc_brlitdir)   $ psuedo class for literal branch.
     180
     181 .=zzyorg z
     182      +*  lexc_max = lexc_brlitdir **
     183
     184
     185      $   literal codes used to parse grammar.
     186      defc(lc_ltsym)     $ '<'
     187      defc(lc_gtsym)     $ '>'
     188      defc(lc_eqsym)     $ '='
     189      defc(lc_divide)     $ '/'
     190      defc(lc_times)     $ '*'
     191      defc(lc_lparen)     $ '('
     192      defc(lc_rparen)     $ ')'
     193      defc(lc_minus)     $ '-'
     194      defc(lc_plus)     $ '+'
     195      defc(lc_set)     $ 'set'
     196      defc(lc_comma)     $ '
     197      defc(lc_ok)     $ 'ok'
     198      defc(lc_b)     $ 'b'
     199      defc(lc_option)     $ 'option'
     200      defc(lc_litmap)     $ 'litmap'
     201      defc(lc_lexmap)     $ 'lexmap'
     202      defc(lc_epc)     $ 'epc'
     203      defc(lc_mode)     $ 'mode'
     204      defc(lc_end)     $ 'end'
     205      defc(lc_op1)  $ 'op1'
     206      defc(lc_op2)  $ 'op2'
     207      defc(lc_op3)  $ 'op3'
     208      defc(lc_op4)  $ 'op4'
     209      defc(lc_op5)  $ 'op5'
     210
     211      defc(lc_error)  $ for name error, so can find 'error' index.
dse    3      defc(lc_errmp)  $ for name errmp, so can find 'errmp' index.
     212      defc(lc_synhalist)  $ .synhalist. - dump syn ha.
     213      defc(lc_synptlist)  $ .synptlist. - dump syn pt.
     214      defc(lc_synoptrace)  $ .synoptrace. - turn on syn pt trace.
     215      defc(lc_synnooptrace) $ .synnooptrace. - turn off syn pt trace.
     216      defc(lc_syntoktrace)  $ .syntoktrace. - turn on token trace.
     217      defc(lc_synnotoktrace)  $ .synnotoktrace. - turn off token trace.
     218
     219 .=zzyorg  z
     220
     221 $    p a r s e t a b   f i e l d s
     222
     223      +*  parse_op = .f. 1, 4,   **    $ parse item opcode
     224      +*  parse_parm = .f. 5, 12, **    $ parse item parameter
     225 $ parse_parm is divided into 2 subfields for the set operation
     226 $ which has 2 parameters
     227      +*  parse_parm1 = .f. 5, 3, **    $ stores register number(1-4)
     228      +*  parse_parm2 = .f. 8, 9, **   $ stores integer value
     229      +*  parsesz = 16 **    $ size of parse item
     230
     231      +*  maxint  = 511 **   $ maximum value for parse_parm2
     232
     233 $ p a r s e t a b   m a c r o s
     234
     235      +*  emitop(o, a) =  $ create a ptab entry and push in on
     236                        $ deftab
     237          parse_op parseskel = o;
     238          parse_parm parseskel = a;
     239          countup(defptr, deftabdim, 'deftab');
     240          deftab(defptr) = parseskel;
     241          **
     242
     243      $   map type codes for ha symbols.
     244 .=zzyorg z
     245      defc(mtyp_lex)  $ resolve to lexical code.
     246      defc(mtyp_lit)  $ resolve to literal code.
     247      defc(mtyp_act)  $ resolve action sequence to label index.
     248      defc(mtyp_im1)  $ implicit macro 1
     249      defc(mtyp_im2)  $ implicit macro 2
     250      defc(mtyp_im3)  $ implicit macro 3
     251      defc(mtyp_im4)  $ implicit macro 4
     252
     253
     254 $ h a   m a c r o s
     255
     256 $ ha fields
     257
     258      +*  ha_names     = .f. 01, 11, **  $ names index.
     259      +*  ha_len       = .f. 12, 06, **  $ length of name.
     260      +*  ha_islbl     = .f. 18, 01, **  $ is label in pt.
     261      +*  ha_mtyp      = .f. 19, 03, **  $ map type.
     262      +*  ha_mval      = .f. 22, 11, **  $ map value.
     263 .-s10    +*  ha_pt        = .f. 33, 11, **  $ pt index if pt symbol.
dsd   10      +*  ha_synlc     = .f. 44, 06, **  $ literal code if grammar symbo
dsd   11      +*  ha_next      = .f. 50, 11, **  $ next ha index in chain.
dsd   12 .+s10    +*  ha_pt        = .f. 61, 11, **   $ pt index if pt synbol.
     267
     268      +*  hamvalsafe = 511 **  $ maximum safe mval.
dsd   13      +*  hasynlcsafe = 63 **  $ maximum safe synlc value.
     270
     271    $ define headers for message classes
     272      +*  error_notice   = '*****error**** ' **
     273      +*  system_notice  = '*system error* ' **
     274      +*  warning_notice = '****warning*** ' **
     275
       1 .=member start
       2
       3      prog start;  $ main program.
       4
       5      $   define global variables and structures.
       6      $   it is assumed that this text compiled with 'default access'
       7      $   option so that every procedure may refer to globals defined in
       8      $   this procedure.
       9
      10
      11      size  arg(ps);    $ saves ha index of literal, lexical, name, etc
      12      size  int1(ps);   $ saves lexical integer item
      13      size  ival(ps);    $ saves lexical integer item value
      14
      15      size  errmax(ps);  $ maximum error number used in grammar.
      16      data  errmax = 0;
      17      size  ermsgarg(ps);  $ pass optional arg to ermsg.
      18
      19      size  linelisted(ps);  data linelisted = 0; $ on when line listed
      20
      21      +*  hasz =  $ size of ha in bits
      22 .+s66  60
vax   13 .+s32  64
      23 .+s37  64
utsa  14 .+s47  64
      24 .+s10    72
      25        **
      26
      27      $   the hash algorithm requires that hamax be a prime.
      28      $   possible values include 509, 599, 701, 787 and 907.
      29      +*  hamax = 907 **  $ ha dims / must be prime.
      30      +*  haxtra = 200 **  $ number of additional ha entries for
      31           $ internally generated labels
      32 .+s66  nameset blank;   $ keep in blank common on s66
      33      size  ha(hasz);  dims ha(hamax + haxtra);
      34 .+s66  end nameset;
      35      size  haused(ps);  data haused=0;  $ number of ha entries used.
      36      size  haxtrap(ps);  data haxtrap = 0;
      37
      38      size  errloc(ps); data errloc = 0;  $ location in ptab
      39               $ of error recovery
      40
dse    4      size  errmploc(ps); data errmploc = 0;  $ location in ptab
dse    5               $ of  symbol (for setl).
dsd   16
      41
      42      $   imara tracks implicit macros.  if imara(i) is nonzero, then
      43      $   the i-th letter of the alphabet is used for implicit macros,
      44      $   and imara(i) gives the mtyp code used.
      45
      46      size  imara(ps);  dims imara(26);  $ implicit macro code array.
      47      data  imara = 0(26);
      48      size  insnamstr(.sds. toklenmax);
      49      data  insnamstr = '' .pad. toklenmax;
      50
      51      $   lexlenmax is maximum length of lexical name in grammar.
      52      $   litlenmax is maximum length of literal in grammar.
      53      size  lexlenmax(ps);  data lexlenmax = 0;
      54      size  litlenmax(ps);  data litlenmax = 0;
      55
dsc   10      +*  binfile = 5 **  $ binary file for setl option.
dsf   17      +*  asmfile = 6 **  $ assembler text to unit 6 (see ptasm).
dsc   11
dsi   15      size  asmfilename(.sds. filenamelen);  $ asm file name.
dsi   16      size  binfilename(.sds. filenamelen);  $ bin file name.
      56      size  macroprefix(.sds. filenamelen);  $ macro prefix string.
      57      size  memberprefix(.sds. filenamelen);  $ start of member names.
      58      size  mtyporg(ps);  dims mtyporg(7);
      59      data  mtyporg = 0(7);
      60      size  mtyplast(ps);  dims mtyplast(7);  data mtyplast = 0(7);
      61      size  mtyptot(ps);  dims mtyptot(7);  data mtyptot = 0(7);
      62      size  mtypnum(ps);  dims mtypnum(7);  data mtypnum = 0(7);
      63
      64      $   characters in symbolic names are kept in -names- array.
      65      +*  namesmax =   $ dimension of -names- array
      66 .+s66    800
vax   14 .+s32    1600
      67 .+s37    1600
utsa  15 .+s47    1600
mgfa   5 .+s10    1600
      69          **
      70
      71      size  namesptr(ps);  data namesptr = 0; $ ptr to names array
      72 .+s66    nameset blank;  $ keep in blank common on s66.
      73      size  names(ws); dims names(namesmax);  $ names array
      74 .+s66    end nameset;
      75
      76      size  nextokha(ps);    $ ha index of last token from nextok.
      77      data  nextokha = 0;
      78
      79      size  linenumber(ps); data linenumber = 0;  $ number of lines read
      80      size  jumpnext(ps);  $ head of list of unresolved references
      81                          $ in ptab
      82      data jumpnext = 0;
      83
      84      size  nerrors(ps);  data nerrors = 0;  $ no of errors
      85      size  nwarnings(ps);  data nwarnings=0; $ num. of warnings.
      86      size  halistflag(ps);   $ flag to dump ha
      87      data  halistflag = 0;
      88      size  opnames(.sds. 3);   $ array of opcode names
      89      dims  opnames(16);
      90
      91      size  lastcol(ps);  $ last column on file 2 to use.
      92
      93      size  lcs_opt(ps);      $ list parse statistics flag
      94      size  listpt(1);      data listpt = no;  $ list pt flag
      95      size  listsw(1);      data listsw = yes;  $ list input flag
      96
      97      size  definertot(ps);  $ number of definers
      98      +*  errnummax = 256 **  $ maximum error number.
      99      size  errbit(errnummax * 2);   $ table of error numbers used
     100      data errbit = 0;
     101      +*  errbits(i) =    $ macro to access errbit
     102          .f. (i-1)*2 + 1, 2, errbit **
     103
     104
     105      size  parsetrace(ws); $ on to trace parser
     106      data  parsetrace = no;  $  trace parser action
     107
     108 $ p a r s e t a b  stores grammar produced by syn
     109
     110      +*  ptabmax = 2000 **
     111 .+s66   nameset blank;
     112      size  ptab(ws);  dims ptab(ptabmax);
     113 .+s66   end nameset;
     114      size  keeptok(ps);   $ lexical scanner keep tokenflag
     115      data keeptok = no;
     116      size  parseskel(ws);   $ ptab entry
     117      size  ptablim(ps);      $ ptab pointer
     118      data  ptablim = 0;
     119      $   ptablimout is ptablim written to member file.  ptablimout is
     120      $   ptablim rounded up to nearest multiple of epc.
     121      size  ptablimout(ps);  data ptablimout = 0;
     122
     123 $ d e f t a b  stores primary and secondary parse items
     124 $ after a definer is found, the primaries and secondaries
     125 $ are merged into ptab.
     126
     127      +*  deftabdim = 50 **
     128      size  deftab(ws);  dims deftab(deftabdim);
     129      size  defptr(ps);  data defptr = 0;
     130      size  secptr(ps);  $ beginning of secondary items in deftab
     131
     132 $ p t  stores parse table of self-defining syn grammar
     133
     134      nameset pt;
     135      size  pt(ws);    $ parse table
     136      dims  pt(pt_dim);
     137      end nameset;
     138      data  pt =
     139 $ member syntab
     140      4b'0799 0035', 4b'0137 0075', 4b'0011 0002', 4b'00aa 0013', $   1
     141      4b'0035 0017', 4b'0023 0016', 4b'0033 0027', 4b'0043 0021', $   2
     142      4b'0139 0002', 4b'0037 0002', 4b'018a 0053', 4b'0002 0031', $   3
     143      4b'0209 0047', 4b'0063 0041', 4b'0689 0051', 4b'0002 0026', $   4
     144      4b'0245 0061', 4b'0002 0066', 4b'0002 02d5', 4b'0415 0455', $   5
     145      4b'04d5 0515', 4b'05e5 0605', 4b'0057 0355', 4b'0016 0073', $   6
     146      4b'0027 0083', 4b'0071 0002', 4b'0016 0093', 4b'0057 03d5', $   7
     147      4b'0027 00a3', 4b'0081 0002', 4b'0027 00b3', 4b'0091 0002', $   8
     148      4b'00a1 0077', 4b'00c3 0002', 4b'0016 0495', 4b'00b1 0002', $   9
     149      4b'0036 0163', 4b'00c1 0002', 4b'0016 00d3', 4b'00d1 0002', $  10
     150      4b'0067 00e3', 4b'0036 00f3', 4b'00e1 00b7', 4b'0103 0036', $  11
     151      4b'0113 0077', 4b'0123 00f1', 4b'0002 0101', 4b'0002 0067', $  12
     152      4b'0133 0036', 4b'0143 0077', 4b'0153 0111', 4b'0002 0087', $  13
     153      4b'0002 00d7', 4b'06e5 0121', 4b'0002 0036', 4b'0725 00c1', $  14
     154      4b'0002 0016', 4b'0765 00d1', 4b'0002 0131', 4b'0088 0002', $  15
     155      4b'00e7 07d5', 4b'0879 0002', 4b'0107 0825', 4b'00a8 0979', $  16
     156      4b'0002 00f7', 4b'0002 00b8', 4b'09f9 0002', 4b'0127 08f5', $  17
     157      4b'0037 0173', 4b'0036 0183', 4b'0141 0002', 4b'0117 0002', $  18
     158      4b'0037 0173', 4b'0036 0183', 4b'0151 0002', 4b'0026 0002', $  19
     159      4b'0037 0173', 4b'0036 0183', 4b'0161 0002', 4b'0026 0002', $  20
     160      4b'0037 0173', 4b'0036 0183', 4b'0171 0002', 4b'0ad9 0047', $  21
     161      4b'0002 0b09', 4b'0139 0035', 4b'0046 0002', 4b'0002 0056', $  22
     162      4b'0002 0002' ;                                             $  23
     163 $ end member syntab
     164
     165 $    globals used by -parse- as parameters
     166      size  parsereg(ps);  dims parsereg(8);  $ parse registers.
     167      data  parsereg = 0(8);
     168
     169      +*  parseok = parsereg(1) **   $ the parseflab is reg1
     170      +*  ermsgno = parsereg(2) **   $ the -ermsgno- is reg2
     171      +*  litmapflag = parsereg(3) **  $ user supplies literal number ma
     172      +*  lexmapflag = parsereg(4) **  $ user supplies lexical number ma
     173
     174
     175      size  epc(ps);  $ number of parse items to pack
     176                     $ into word of ptab
     177
     178      +*  peldefault = 50 ** $ default error limit.
     179      size  pelvalue(ps);  data pelvalue = peldefault;  $ error limit
     180
     181
     182      size  sdsnamstr(.sds. toklenmax);
     183      data  sdsnamstr= '' .pad. toklenmax; $ parameter to
     184
     185
     186      $   as part of error report, syn lists the most recent
     187      $   lexlistmax tokens.  lexlistmax must be a power of two.
     188
     189      +*  lexlistmax = 16 **
     190
     191      size  lexlist(ps);  dims lexlist(lexlistmax);
     192      data lexlist = 0(lexlistmax);
     193      size  lexlistptr(ps);  data lexlistptr = 0;
     194      size  listwds(ws); dims listwds(wpc);  $ line read in
     195      size  listwdsp(ps);   $ last non-blank word
     196
dsc   12      size  res4ent(ws);        $ binary result of last res4 result.
dsc   13      size  setlopt(ps);      $ setl option.
dsc   14
dsf   18      size  asmtype(ps);  $ target machine for assembler text.
     197      size  timestr(.sds. lctimelen);   $ stores time/date string
     198
     199      +*  tokrbuflim = 256 **
     200      +*  tokarasz = ws **  $ size of tokara
     201      +*  tokaradims = ((toklenmax+cpw)/cpw) **
     202      $   review tokaradims carefully when building cross compiler
     203      $   where character sizes differ
     204      size  toklen(ps);  $ token length in characters
     205      size  toklt(ps);  $ token lexical type
     206      size  toklc(ps);   $ token hash table index
     207 .+s66    nameset blank;  $ keep in blank common on s66.
     208      size  tokrbuf(ws);  dims tokrbuf(tokrbuflim);  $ token buffer
     209 .+s66    end nameset;
     210      size  tokrbufp(ps);  data tokrbufp=0;  $ ptr to tokrbuf
     211
     212      call synini;  $ to initialize program and print title
     213      call parse;
     214      call synexit(0);
     215      end prog start;
       1 .=member synini
       2      subr synini;  $ initialization.
       3
       4      size  parm1(ws);    $ to store params for op_set
       5      size  i(ps);     $ do loop variable
       6      size  imchars(.sds. filenamelen);  $ im code chars
       7      size  mt(ps);  $ map type
       8      size  imtot(ps);    $ number of implicit macros
       9      size  s1(.sds. 1);      $ one character temporary string
      10      size  n(ps);            $ temporary
      11      size  iorc(ps);  $ io return code
      12      size  parsefilename(.sds. filenamelen);  $ name of parse file
      13      size  tokenfilename(.sds. filenamelen);  $ name of token file
      15      size  hap(ps);    $ ha index.
      16
      17      do  i = 1 to hamax;  $ clear ha
      18          ha(i) = 0;  end do;
      19
      20      $   initialize opnames, setting to '**n' if n not an op.
      21
      22      do  i = 0 to 15;
      23          opnames(i+1) = '***';
      24          .ch. 3, opnames(i+1) = hexcharofdig(i);
      25          end do;
      26      opnames(op_lit+1) = 'lit';
      27      opnames(op_lex+1) = 'lex';
      28      opnames(op_sev+1) = 'sev';
      29      opnames(op_sub+1) = 'sub';
      30      opnames(op_err+1) = 'err';
      31      opnames(op_bak+1) = 'bak';
      32      opnames(op_jif+1) = 'jif';
      33      opnames(op_jmp+1) = 'jmp';
      34      opnames(op_act+1) = 'act';
      35      opnames(op_set+1) = 'set';
      36      opnames(op_op1+1) = 'op1';
      37      opnames(op_op2+1) = 'op2';
      38      opnames(op_op3+1) = 'op3';
      39      opnames(op_op4+1) = 'op4';
      40      opnames(op_op5+1) = 'op5';
      41
      42
      43 $ hash into ha literals of syn sgrammar
      44      +*  hashin(s, lc) = call haini(s, lc); **
      45      hashin('<',   lc_ltsym)
      46      hashin('>',   lc_gtsym)
      47      hashin('=',   lc_eqsym)
      48      hashin('/',   lc_divide)
      49      hashin('*',   lc_times)
      50      hashin('(',   lc_lparen)
      51      hashin(')',   lc_rparen)
      52      hashin('-',   lc_minus)
      53      hashin('+',   lc_plus)
      54      hashin('set', lc_set)
      55      hashin(',',   lc_comma)
      56      hashin('ok',  lc_ok)
      57      hashin('b',   lc_b)
      58      hashin('option',  lc_option)
      59      hashin('litmap',  lc_litmap)
      60      hashin('lexmap',  lc_lexmap)
      61      hashin('epc',    lc_epc)
      62      hashin('mode',    lc_mode)
      63      hashin('end', lc_end)
      64
      65      hashin('op1',  lc_op1)
      66      hashin('op2',  lc_op2)
      67      hashin('op3',  lc_op3)
      68      hashin('op4',  lc_op4)
      69      hashin('op5',  lc_op5)
      70      hashin('error', lc_error)   $ ha index of symbol 'error'
      71      hashin('.synhalist.' ,lc_synhalist);
      72      hashin('.synptlist.',  lc_synptlist);
      73      hashin('.synoptrace.', lc_synoptrace);
      74      hashin('.synnooptrace.', lc_synnooptrace);
      75      hashin('.syntoktrace.', lc_syntoktrace);
      76      hashin('.synnotoktrace.', lc_synnotoktrace);
      77
      79
      80      call getspp(memberprefix, 'memp=syn/');
      81      call getspp(macroprefix, 'macp=parse/');
      82
      83      call getipp(parsetrace, 'pt=0/1');
dsc   15      call getipp(setlopt,'setl=0/1');  $ setl option.
dsc   16
dse    6      if  setlopt  then  $ in setl mode, look for name .
dse    7          hashin('errmp', lc_errmp)   $ ha index of symbol 'errmp'
dsd   19          end if;
dsd   20      macdrop(hashin)
      84      call getipp(epc, 'epc=2/3');   $ number of parseitems/word
      85      call getipp(lcs_opt, 'lcs=1/0');
      86      call getipp(halistflag, 'ha=0/1');
      87
dsf   19      $   read asm= option, default is off or machine at hand if asm
dsf   20      $   alone specified.
dsf   21 .+s10    call getipp(asmtype, 'asm=0/10');
dsf   22 .+s32    call getipp(asmtype, 'asm=0/32');
dsf   23 .+s37    call getipp(asmtype, 'asm=0/37');
utsa  16 .+s47    call getipp(asmtype, 'asm=0/47');
dsf   24 .+s66    call getipp(asmtype, 'asm=0/66');
vax   15 .+s32    call getspp(tokenfilename, 'tokens=tokens.tmp/');
      88 .+s37    call getspp(tokenfilename, 'tokens=sysut1/');
utsa  17 .+s47    call getspp(tokenfilename, 'tokens=sysut1/');
      89 .+s66    call getspp(tokenfilename, 'tokens=tokens/');
mgfa   6 .+s10    call getspp(tokenfilename, 'tokens=*.tok/');
      91      call opensio(tokenfile, iorc, access_read, tokenfilename,
      92          0, i, 0, 0);
dsia   1 .+s66  call rewisio(tokenfile, iorc, 0);
      94      call dropsio(tokenfile, iorc);  $ this is terminal use of tokenfil
      95      call rdrwsio(tokenfile, iorc, tokrbuf, 1, tokrbuflim);
vax   16 .+s32    call getspp(parsefilename, 'synout=synout.dat/');
dsj   10 .+s37    call getspp(parsefilename, 'synout=synout/');
utsa  18 .+s47    call getspp(parsefilename, 'synout=synout/');
      97 .+s66    call getspp(parsefilename, 'synout=synout/');
      98 .+s10    call getspp(parsefilename, 'synout=synout.dat/');
dsj   11      file parsefile access = put, linesize = 80, title = parsefilename;
dsj   12 .+s66 rewind parsefile;
     101
dsi   17 .+s32    call getspp(asmfilename, 'synasm=/');
dsi   18 .+s37    call getspp(asmfilename, 'synasm=assemble/');
utsa  19 .+s47    call getspp(asmfilename, 'synasm=assemble/');
dsi   19 .+s66    call getspp(asmfilename, 'synasm=/');
dsi   20 .+s10    call getspp(asmfilename, 'synasm=/');
dsi   21
dsk   14      call getspp(binfilename, 'synbin=0/synbin');
     106
     107      call getspp(imchars, 'im=/');
     108      if  (.len. imchars > 4)  .len. imchars = 4;  $ at most four.
     109      imtot = 0;
     110      do  i = 1 to .len. imchars;
     111          s1 = .s. i, 1, imchars;  $ get code character
     112          n = s1 .in. alphabet;
     113          if  (n=0)  cont do;  $ if not a letter.
     114          if  (imara(n))  cont do;  $ if already specified.
     115          imtot = imtot + 1;
     116          imara(n) = mtyp_im1 + (imtot-1);  $ set map type.
     117          end do;
     118
     119      lastcol = filestat(2,linesize)-6;
     120      call ltitlr(synlevel);
     121      call stitlr(0, 'syn - syntax generator.');
     122      call stitlr(1, 'program parameters.');
     123
     124      timestr = ' ' .pad. 30;
     125      call lstime(timestr);   $ get time/date
     126
     127      put ,'token file: tokens = ' :tokenfilename,a
     128          ,'.  output file: synout = ' :parsefilename,a ,'.' ,skip;
dsi   26      put ,'asm file: synasm = ' :asmfilename,a
dsi   27          ,'.  binary file: synbin = ' :binfilename,a ,'.' ,skip;
     129
     130      put ,'entries per constant: epc = ' :epc,i
     131          ,'.  parse trace: pt = ':parsetrace,i ,'.' ,skip;
     132      put ,'ha dump: ha = ' :halistflag,i ,'.' ,skip;
     133      put ,'macro prefix: macp = ' :macroprefix,a
     134          ,'.  member prefix: memp = ' :memberprefix,a ,'.' ,skip;
     135      put ,'implicit macros: im = ' :imchars,a ,'.' ,skip;
dsc   17      put ,'setl: setl = ' :setlopt,i ,'.' ,skip;
dsf   25      put ,'assembler text type: asm = ' :asmtype,i ,'.' ,skip;
     136      call stitlr(1, 'grammar listing.');
     137      put ,skip(2);
     138      end subr synini;
       1 .=member haini
       2      subr haini(s, lc);  $ initialize synlc for string s.
       3      size  s(.sds. 20);
       4      size  lc(ps);      $ syn literal code.
       5      size  l(ps);      $ string length.
       6      size  hap(ps);     $ ha index.
       7
       8      l = .len. s;  assert l <= toklenmax;
       9      .len. insnamstr = l;
      10      .s. 1, l, insnamstr = s;
      11      call insnam(hap);
      12      assert lc <= hasynlcsafe;  $ avoid field overflow.
      13      ha_synlc ha(hap) = lc;
      14      end subr haini;
       1 .=member parse
       2      subr parse;  $ parse grammar.
       3
       4 $ parser stack -pca- macros
       5
       6
       7      size  parsenow(ps);    $ ptable -pt- pointer
       8      size  parseop(ps);     $ current parse operation
       9      size  parseparm(ps);  $ current parse parameter
      10      size  lc(ps);   $ literal ha code
      11      size  i(ps);        $ do loop variable
      12      size  tot(ps);  $ sum of  objects found
      13      size  p1(ps);    $ parameter1
      14      size  p2(ps);    $ parameter2
      15
      16      +*  pcamax = 50 **
      17      +*  pcaret(i) = .f. 01, 11, pca(i) **   $ return address
      18      +*  pcaprm(i) = .f. 12, 11, pca(i) ** $ seek several branch target
      19      +*  pcatot(i) = .f. 23, 10, pca(i) **  $ totol no of items found
      20      size  pca(32);         $ parse stack
      21      dims  pca(pcamax);
      22      size  pcaptr(ps);      $ pointer to pca
      23      pcaptr = 0;  tot = 0;
      24
      25
      26      $   unpack parse table, two entries per constant.
      27      do  i = pt_dim/2 to 1 by -1;
      28          pt(i*2) = .f. 01, 16, pt(i);
      29          pt(i*2-1) = .f. 17, 16, pt(i);
      30          end do;
      31
      32      parsenow = 1;
      33      go to parseon;
      34
      35 /parseoncond/  $ advance parse according to parseok state.
      36      keeptok = 1 - parseok;
      37      parsenow = parsenow + 1 + parseok;
      38      go to parseon;
      39
      40 /parsenext/  $ advance to next parse op.
      41
      42      parsenow = parsenow + 1;
      43
      44 /parseon/   $ interprep next parse item
      45
      46      parseop = parse_op pt(parsenow);
      47      parseparm = parse_parm pt(parsenow);
      48
      49      if  parsetrace  then  $ if tracing parse.
      50          put ,x(4) ,'parsetrace ' :parseok :parsenow
      51              :parseop :parseparm,nil ,x :opnames(parseop+1),al ,skip;
      52          end if;
      53
      54      go to po(parseop) in 1 to op_max;
      55
      56
      57 /po(op_lit)/     $ seek literal.
      58
      59      call nextok;   $ get next token
      60      parseok = (parseparm = toklc);
      61      go to parseoncond;
      62
      63 /po(op_lex)/    $ seek lexical.
      64
      65      call nextok;   $ get next token
      66      go to lexc(parseparm) in 1 to lexc_max;
      67
      68 /lexc(lexc_name)/   $ seek <*name>.
      69
      70      parseok = (toklt = nametok);
      71      if  (parseok)  arg = nextokha;
      72      go to parseoncond;
      73
      74 /lexc(lexc_string)/   $ seek <*string>.
      75
      76      parseok = (toklt = strtok);
      77      if  (parseok)  arg = nextokha;  $ save ha index if found.
      78      go to parseoncond;
      79
      80 /lexc(lexc_int)/    $ seek <*int>.
      81
      82      parseok = (toklt = dectok);
      83      if  parseok  then $ if integer found, convert it.
      84          ival = 0;   $ result stored in -ival-
      85          do  i = 1 to (.len. insnamstr);
      86              ival = ival * 10 + digofchar((.ch. i, insnamstr));
      87              end do;
      88          end if;
      89      go to parseoncond;
      90
      91 /lexc(lexc_nonslash)/     $ seek any token but '/'.
      92
      93      parseok = (toklc ^= lc_divide);
      94      go to parseoncond;
      95
      96 /lexc(lexc_noneq)/    $ seek any token but '='.
      97
      98      parseok = (toklc ^= lc_eqsym);
      99      go to parseoncond;
     100
     101 /lexc(lexc_brlitdir)/   $ branch on literal for direct part.
     102      $   here to start direct part, check next token, and
     103      $   branch according to literal case.
     104      i = 0;
     105      if      toklc = lc_ltsym   then  i = 1;
     106      elseif  toklc = lc_lparen  then  i = 2;
     107      elseif  toklc = lc_minus   then  i = 3;
     108      elseif  toklc = lc_plus    then  i = 4;
     109      elseif  toklc = lc_set     then  i = 5;
     110      elseif  toklc = lc_ok      then  i = 6;
     111      elseif  toklc = lc_op1     then  i = 7;  int1 = 1;
     112      elseif  toklc = lc_op2     then  i = 7;  int1 = 2;
     113      elseif  toklc = lc_op3     then  i = 7;  int1 = 3;
     114      elseif  toklc = lc_op4     then  i = 7;  int1 = 4;
     115      elseif  toklc = lc_op5     then  i = 7;  int1 = 5;
     116          end if;
     117      parseok = (i > 0);
     118      keeptok = 1 - parseok;
     119      parsenow = parsenow + 1 + i;
     120      go to parseon;
     121
     122 /po(op_sev)/     $ seek several subparts.
     123
     124      countup(pcaptr, pcamax, 'ptab');
     125      pca(pcaptr) = 0;
     126      pcaret(pcaptr) = parsenow;   $ save return place
     127      pcaprm(pcaptr) = parseparm;  $ save place branching to
     128      parsenow = parseparm;
     129      go to parseon;
     130
     131 /po(op_sub)/   $ seek subpart.
     132
     133      countup(pcaptr, pcamax, 'ptab');
     134      pca(pcaptr) = 0;
     135      pcaret(pcaptr) = parsenow;
     136      parsenow = parseparm;
     137      go to parseon;
     138
     139 /po(op_err)/      $ process error
     140
     141      if  parseok  then
     142          parsenow = parsenow + 1;
     143          go to parseon;
     144          end if;
     145      ermsgno = parseparm;
     146      call ermet;
     147      pcaptr = 0;  $ clear parse stack for error recover
     148      parsenow = locofer;   $ location in pt of error processing 
     149      go to parseon;
     150
     151
     152 /po(op_bak)/   $ restore parse state
     153
     154 $ return from find subpart or find repeated instances of subpart.
     155
     156      if  pcaprm(pcaptr) = 0  then   $ seek one instance case.
     157          parsenow = pcaret(pcaptr) + parseok + 1;
     158          pcaptr = pcaptr - 1;
     159          if  (pcaptr >= 0)  go to parseon;
     160          call ermey(2);  $ fatal pca underflow.
     161
     162      else  $ seek several instances.
     163
     164          if  parseok  then     $ continue search
     165              pcatot(pcaptr) = pcatot(pcaptr) + 1;   $ increment count
     166              $ of items found
     167              parsenow = pcaprm(pcaptr);
     168              go to parseon;
     169          else    $ subpart not found.  return to point of call.
     170              parsenow = pcaret(pcaptr) + 1;
     171              parseok = yes;    $ 0 instances valid
     172              tot = pcatot(pcaptr);  $ total subparts found
     173              pcaptr = pcaptr - 1;
     174              if  (pcaptr >= 0)  go to parseon;
     175              call ermey(2);  $ fatal pca underflow.
     176              end if;
     177          end if;
     178
     179 /po(op_jif)/    $ conditional transfer    -lab
     180
     181      if  parseok  then
     182          parsenow = parsenow + 1; go to parseon;
     183          end if;
     184      parsenow = parseparm;
     185      go to parseon;
     186
     187 /po(op_jmp)/      $ transfer    +lab
     188
     189      parsenow = parseparm;
     190      go to parseon;
     191
     192 /po(op_set)/       $ set register   set(r, iv)
     193
     194      p1 = parse_parm1 pt(parsenow) + 1;
     195      p2 = parse_parm2 pt(parsenow);
     196
     197      parsereg(p1) = p2;
     198      go to parsenext;
     199
     200 /po(op_op1)/  /po(op_op2)/  /po(op_op3)/
     201 /po(op_op4)/  /po(op_op5)/
     202      put ,'error - attempt to use user op operation.' ,skip;
     203      put :parsenow,nil ,skip;
     204      call synexit(1);
     205      go to parsenext;
     206
     207 /po(op_act)/    $ execute code
     208
     209      go to pa(parseparm) in 1 to parseactmax;
     210
     211    +* pac = go to parsenext; **
     212
     213 $ member synact
     214 / pa(   1) /  call synexit ( 0 );                               pac;
     215 / pa(   2) /  call gnam;                                        pac;
     216 / pa(   3) /  call gdir;                                        pac;
     217 / pa(   4) /  go to g_alt;
     218 / pa(   5) /  call galt;                                        pac;
     219 / pa(   6) /  call glit;                                        pac;
     220 / pa(   7) /  call glex;                                        pac;
     221 / pa(   8) /  go to g_sev;
     222 / pa(   9) /  go to g_sub;
     223 / pa(  10) /  call gact;                                        pac;
     224 / pa(  11) /  go to g_jif;
     225 / pa(  12) /  go to g_err;
     226 / pa(  13) /  go to g_jmp;
     227 / pa(  14) /  go to g_saveint;
     228 / pa(  15) /  call gset;                                        pac;
     229 / pa(  16) /  go to g_ok;
     230 / pa(  17) /  go to g_opn;
     231 / pa(  18) /  go to g_bak;
     232 / pa(  19) /  go to g_next;
     233 / pa(  20) /  go to g_mode;
     234 / pa(  21) /  go to g_epc;
     235 / pa(  22) /  go to g_lexmap;
     236 / pa(  23) /  go to g_litmap;
     237 $ end member synact
     238
     239     macdrop(pac)
     240
     241 /g_epc/  $ set entries per constant.
     242      epc = ival;
     243      go to parsenext;
     244
     245 /g_lexmap/    $ assigns lexical code to name.
     246
     247      call setmtyp(arg, mtyp_lex);
     248
     249      if  ha_mtyp ha(arg) ^= mtyp_lex  then  $ if wrong type.
     250          ermsgarg = arg;  call ermsg(12);  $ name in use.
     251          ival = ha_mval ha(arg);  $ get current value.
     252      elseif  ha_mval ha(arg)  then  $ if value already set.
     253          ermsgarg = arg;  call ermsg(13);
     254          ival = ha_mval ha(arg);
     255      else  $ if first encounter, adjust lexlenmax.
     256          if  (ha_len ha(arg) > lexlenmax)  lexlenmax = ha_len ha(arg);
     257          end if;
     258
     259      ha_mval ha(arg) = ival;  assert ival <= hamvalsafe;
     260      go to parsenext;
     261
     262 /g_litmap/     $ assign literal code to literal.
     263
     264      call setmtyp(arg, mtyp_lit);
     265
     266      if  ha_mtyp ha(arg) ^= mtyp_lit  then  $ if wrong type.
     267          ermsgarg = arg;  call ermsg(12);  $ name in use.
     268          ival = ha_mval ha(arg);  $ get current value.
     269      elseif  ha_mval ha(arg)  then  $ if value already set.
     270          ermsgarg = arg;  call ermsg(13);
     271          ival = ha_mval ha(arg);
     272      else  $ if first encounter, adjust litlenmax.
     273          if  (ha_len ha(arg) > litlenmax)  litlenmax = ha_len ha(arg);
     274          end if;
     275
     276      ha_mval ha(arg) = ival;  assert ival <= hamvalsafe;
     277      go to parsenext;
     278
     279 /g_alt/   $ beginning of secondary items
     280
     281      secptr = defptr + 1;  $ mark beginning of secondary definer items
     282      go to parsenext;
     283
     284 /g_sev/     $ seek several.
     285
     286      emitop(op_sev, arg);
     287      ha_islbl ha(arg) = yes;  $ flag as name used.
     288      go to parsenext;
     289
     290 /g_sub/     $ seek syntactic subpart.
     291
     292      emitop(op_sub, arg);
     293      ha_islbl ha(arg) = yes;
     294      go to parsenext;
     295
     296
     297 /g_err/       $ error if ok = false
     298
     299      emitop(op_err, ival);    $ emit op_err item
     300      if  (errbits(ival) < 2)    $ note use if errno -ival-
     301          errbits(ival) = errbits(ival) + 1;
     302      go to parsenext;
     303
     304 /g_saveint/
     305
     306      int1 = ival;   $ save value of ival
     307      go to parsenext;
     308
     309 /g_ok/
     310
     311 $ the primitive -ok- becomes  set(1, 1)
     312      int1 = 1;  ival = 1;
     313      call gset;
     314      go to parsenext;
     315
     316
     317 /g_opn/  $ emit opn operation.
     318
     319      emitop((op_op1+int1-1), ival);
     320      go to parsenext;
     321
     322 /g_bak/
     323
     324      emitop(op_bak, 0);
     325      go to parsenext;
     326
     327 /g_jmp/     $ unconditional transfer
     328
     329      emitop(op_jmp, arg);
     330      ha_islbl ha(arg) = yes;
     331      go to parsenext;
     332
     333 /g_jif/     $ conditional transfer if ok = false
     334
     335      $   primary.
     336      emitop(op_jif, arg);
     337      ha_islbl ha(arg) = yes;
     338      go to parsenext;
     339
     340 /g_next/   $ conditional transfer to next definer
     341               $ internally generated labels
     342      if  jumpnext = 0  then  $ allocate new ha entry
     343          countup(haxtrap, haxtra, 'haxtra');
     344          jumpnext = haxtrap + hamax;
     345          end if;
     346      arg = jumpnext;
     347      emitop(op_jmp, arg);
     348      go to parsenext;
     349
     350 /g_mode/  $ process mode option.
     351      go to parsenext;
     352      end subr parse;
       1 .=member setmtyp
       2      subr setmtyp(hap, mt);  $ set mtyp of ha(hap), chain if new.
       3      size  hap(ps);   $ ha index.
       4      size  mt(ps);    $ desired mtyp value.
       5
       6      if (ha_mtyp ha(hap)) return; $ if type already set.
       7      ha_mtyp ha(hap) = mt;  $ set type.
       8      if  mtyporg(mt)=0  then  $ if first instance of type.
       9          mtyporg(mt) = hap;
      10      else
      11          ha_next ha(mtyplast(mt)) = hap;
      12          end if;
      13      mtyplast(mt) = hap;
      14      mtypnum(mt) = mtypnum(mt) + 1;
      15      end subr setmtyp;
       1 .=member gtoflo
       2      subr gtoflo(ipoin, lim);  $ increment counter
       3      $   increment -ipoin-, fatal error if -ipoin- >= -lim-.
       4      size  ipoin(ps);
       5      size  lim(ps);
       6      size  iword(ws+1);  $ name of array which overflowed
       7
       8      terml(yes);  $ write this to terminal file
       9      put ,error_notice ,' array overflow with index '
      10          :ipoin,i ,', with limit ' :lim,i ,skip;
      11      terml(no);  $ done with terminal file output
      12      call synexit(1);  $ terminate
      13      end subr gtoflo;
       1 .=member nextok
       2      subr nextok(hap);  $ get next token
       3      $   obtain next token from input stream, unless -keeptok- is on,
       4      $   in which case return prior token.
       5      $   check for 'special' period-delimited tokens,
       6      $   such as '.voadump.' which requests symbol table dump, etc.
       7      $   set -toklc- to literal code, -toklt- to lexical type,
       8      $   -toklen- to length of token in characters,
       9      $   -tokwords- to number of words in
      10      $   token, and insert token in array -tokara-.
      11      size  i(ps);            $ do loop index
      12      size  tokhdr(ws);  $ token descriptor word
      13      size  toktrace(1); data toktrace=0;  $ on to trace tokens read
      14      size  tokwords(ps);  $ no of words in token value
      15      size  toklclex(ps);  $ literal code from lex.
      16      size  fsd(ps);    $ index of first nonzero char in integer.
      17      size  nl(ps);     $ new length if eliminating leading zeros.
      18      size  v(ps);      $ value of implicit macro.
      19      size  c(ps);      $ character temporary.
      20      size  mt(ps);     $ implicit macro type.
      21      size  tokara(tokarasz); dims tokara(tokaradims); $ token array
      22
      23      +*  tokread1(wd) = $ get one word from token buffer/file
      24          if  tokrbufp >= tokrbuflim  then
      25          size  zzzv(ps);     $ io return code.
      26          call rdrwsio(tokenfile, zzzv, tokrbuf, 1, tokrbuflim);
      27              tokrbufp=0;
      28              end if;
      29          tokrbufp = tokrbufp + 1;  wd = tokrbuf(tokrbufp);
      30          **
      31
      32      +*  tokread(ara, wds) = $ read wds words into ara(1) to ara(wds).
      33          size  zzzi(ps);  $ do loop index.
      34          if  (wds+tokrbufp) >= tokrbuflim  then $ if would empty buf,
      35              do  zzzi = 1 to wds;
      36                  tokread1(ara(zzzi)); end do;
      37          else
      38              do  zzzi = 1 to wds;
      39                  ara(zzzi) = tokrbuf(tokrbufp + zzzi);  end do;
      40              tokrbufp = tokrbufp + wds;
      41              end if;
      42          **
      43      $   do  not read token till -find- clears -keeptok-
      44
      45      if  (keeptok)  return;
      46      keeptok = yes;
      47 /rdtok/
      48      tokread1(tokhdr);  $ read token descriptor
      49      toklt =tokrtyp tokhdr;  $ get lexical type/code
      50      toklclex = tokrlc tokhdr;
      51      toklen = tokrlen tokhdr;  $ no ov chars
      52      if  toktrace  then
      53          put ,'token trace ' :toklt :toklen :toklc,nil ,skip;
      54          end if;
      55      tokwords = (toklen-1)/cpw + 1;  $ no of words
      56      if  (toklen = 0)  tokwords = 0;
      57      go to t(toklt) in 1 to tokreof;
      58  /t(listcontroltok)/  $  .=list directive or change.
      59      if  toklen = 2  then  $ if list input directive change.
      60          listsw = toklclex;
      61      elseif  toklen = 1  then  $ if list code directive.
      62          listpt = toklclex;
      63          end if;
      64      go to rdtok;
      65 /t(listejecttok)/    $ .=eject
      66      put ,page;
      67      go to rdtok;
      68 /t(listtitletok)/    $ .=title
      69      go to rdtok;
      70
      71 /t(15)/  /t(16)/  /t(17)/  /t(18)/  /t(19)/ /t(20)/  /t(7)/  /t(10)/
      72 /t(21)/  /t(22)/  /t(23)/  /t(24)/  /t(25)/ /t(26)/  /t(11)/  /t(13)/
      73      call ermey(9);
      74
      75 /t(nametok)/
      76 /t(spectok)/
      77 /t(pdotok)/
      78 /t(dectok)/
      79 /t(sstok)/
      80 /t(strtok)/
      81 /t(bittok)/
      82 /t(qstok)/
      83 /t(rztok)/
      84 /t(realtok)/
      85
      86      assert toklen < (toklenmax-cpw);
      87
vax   18 .+s32    tokara(2) = blankword;
      88 .+s37    tokara(2) = blankword;
utsa  21 .+s47    tokara(2) = blankword;
      89      if  toklen <= cpstr  then
      90          tokara(1) = blankword;
      91          tokrval tokara(1) = tokrval tokhdr;
      92      else
      93          tokread(tokara, tokwords);
      94          end if;
      95      if  toktrace  then
      96          put,'token = ';
      97          do  i = 1 to tokwords;
      98               put :tokara(i),r(cpw);
      99              end do;
     100          put ,skip;
     101          end if;
     102      do  i = 1 to tokwords;  $ copy into insnamstr.
     103          .f. (1+.sds. toklenmax)-i*ws, ws, insnamstr = tokara(i);
     104          end do;
     105      .len. insnamstr = toklen;
     106      $   eliminate leading zeros if integer.
     107      if  toklt = dectok  then
     108          fsd = 1;
     109          while fsd1  then  $ if leading zeros.
     114              nl = toklen - fsd + 1;
     115                  toklen = nl;
     116              do  i = 1 to nl;
     117                  .ch. i, insnamstr = .ch. fsd+i-1, insnamstr;
     118                  end do;
     119              .len. insnamstr = nl;
     120              end if fsd;
     121          end if toklt;
     122      call insnam(nextokha);  $ hash token into ha
     123      $   check for possible implicit macro.
     124      until 1;
     125          if  (toklt^=nametok ! toklen<2)  quit until;
     126          c = .ch. 2, insnamstr;
     127          if  (c^=1r_)  quit until;
     128          i = (.s. 1, 1, insnamstr) .in. alphabet;
     129          if  (i=0)  quit until;
     130          if  (imara(i)=0)  quit until;  $ if not implicit macro code.
     131          mt = imara(i);  $ get macro type.
     132          call setmtyp(nextokha, mt);  $ see if correct type.
     133          if  (ha_mtyp ha(nextokha) ^= mt)  quit until;
     134          if  ha_mval ha(nextokha) = 0  then  $ if defining case.
     135              mtyptot(mt) = mtyptot(mt) + 1;
     136              ha_mval ha(nextokha) = mtyptot(mt);
     137              end if;
     138          v = ha_mval ha(nextokha);  $ get value.
     139          $   now hash in value as integer token, and use it.
     140          toklen = 1 + (v>9) + (v>99);
     141          .len. insnamstr = toklen;
     142          do  i = toklen to 1 by -1;
     143              .ch. i, insnamstr = charofdig(mod(v,10));
     144              v = v / 10;
     145              end do;
     146          toklt = dectok;
     147          call insnam(nextokha);
     148          end until;
     149
     150      toklc = ha_synlc ha(nextokha);
     151      lexlist(lexlistptr+1) = nextokha;  $ save token
     152      lexlistptr = (lexlistptr+1) & (lexlistmax-1);
     153 /dotok/
     154      if(toklt ^= pdotok) return;
     155      $   search for special syn directives.
     156      if  (toklc=0)  return;
     157      if  toklc = lc_synhalist  then  $ if .synhalist.
     158          call lstlin;
     159          call halist;
     160          go to rdtok;
     161      elseif  toklc = lc_synptlist  then  $ if .synptlist.
     162          call lstlin;
     163          call ptlist;
     164          go to rdtok;
     165      elseif  toklc = lc_synoptrace  then  $ if .synoptrace.
     166          parsetrace = yes;
     167          go to rdtok;
     168      elseif  toklc = lc_synnooptrace  then  $ if .synnooptrace.
     169          parsetrace = no;
     170          go to rdtok;
     171      elseif  toklc = lc_syntoktrace  then  $ if .syntoktrace.
     172          toktrace = yes;
     173          go to rdtok;
     174      elseif  toklc = lc_synnotoktrace  then  $ if .synnotoktrace.
     175          toktrace = no;
     176          go to rdtok;
     177          end if;
     178      return;
     179 /t(tokrline)/           $  line image being transmitted
     180      tokread(listwds, tokwords); $ read line image
     181      linelisted = no;  $ new line read, not yet listed
     182      linenumber = linenumber + 1;  $ updating line count
     183      listwdsp = tokwords;  $ save length
     184      if  listsw  then    $ list last line
     185          call lstlin;
     186          end if;
     187      go to rdtok;  $ get next token
     188 /t(tokreof)/  $ end-of-file token
     189      call ermsg(19);  call galt;
     190      call synexit(0);
     191      end subr nextok;
       1 .=member lstlin
       2      subr lstlin;  $ list input line.
       3      size  i(ps);    $ loop index.
       4      if  linelisted = no  then   $ must list last line
       5          put :linenumber,i(5) ,x(2);
       6          do  i = 1 to listwdsp;  $ list line image
       7              put :listwds(i),r(cpw);
       8              end do;
       9          put ,skip;
      10          linelisted = yes;  $ show line now listed
      11          end if;
      12      end subr lstlin;
       1 .=member toklist
       2      subr toklist; $ list recent tokens
       3      size  i(ps);  $ index in lexlist
       4      size  n(ps);  $ number listed
       5
       6      put ,x(15),'last few tokens: ';
       7      i = lexlistptr-1; $ set to start
       8      n = 0;
       9      while 1;
      10          i = (i+1) & (lexlistmax-1); $ bump i, modulo lexlistmax
      11          n = n+1; if (n>lexlistmax) quit while;
      12          if  (lexlist(i+1) = 0)  cont while;  $ ignore if not set
      13          call sdsnamr(lexlist(i+1));  $ get string form of token.
      14          put ,x :sdsnamstr,a;
      15          end while;
      16      put ,skip;
      17      listl(listsw=no) put ,skip; listl(yes)
      18      end subr toklist;
       1 .=member sdsnamr
       2      subr sdsnamr(hap);  $ get string form of ha entry
       3      $   convert name in names array to self defined string and
       4      $   return it in global variable sdsnamstr.
       5      size  hap(ps);    $ ha ptr
       6      size  i(ps);    $ do loop index
       7
       8      .len. sdsnamstr = 0;
       9      if  (hap<1 ! hap>hamax)  return;
      10      .len. sdsnamstr =  ha_len ha(hap);   $ set length field
      11      if  (.len. sdsnamstr = 0)  return;
      12      do  i = 1 to (ha_len ha(hap) -1) / cpw+1;
      13          .f.(1+.sds. toklenmax)-ws*i,ws,sdsnamstr
      14              = names(ha_names ha(hap)+i-1);
      15          end do;
      16
      17      end subr sdsnamr;
       1 .=member insnam
       2      subr insnam(hap);   $ insert name into ha.
       3
       4
       5      $   return the ha-index of an item, inserting it in the ha if
       6      $   necessary.
       7
       8      size  hcode(ws);  $ hash code of name
       9      size  j(ps);  $ ha-index of entry benng probed
      10      size  tokwords(ps);  $ words in token.
      11      size  hap(ps);         $ ha-index returned
      12      size  i(ps); $ do look index
      13      size  l(ps);  $ token length in characters.
      14      size  ara(ws);  dims ara((toklenmax+2*cpw)/cpw);
      15      size  probes(ps);   $ probes this search.
      16
      17      l = .len. insnamstr;
      18      tokwords = (l+(cpw-1)) / cpw;
      19      if  (l = 0)  tokwords = 0;
      20      do  i = 1 to tokwords;
      21          ara(i) = .f. (1+.sds. toklenmax)-i*ws, ws, insnamstr;
      22          end do;
      23      i = tokwords*cpw - l;  $ get number of chars to clear
      24      if  (i)  .f. 1, i*cs, ara(tokwords) = blankword;
      25      hcode = ara(1);
      26      do  i = 2 to tokwords;    $ compute hash code
      27          hcode = hcode .ex. ara(i);
      28          end do;
      29      hcode = .f. 1, ws/2, hcode .ex. .f. ws/2+1, ws/2, hcode;
      30      if  (hcode >= hamax) hcode = hcode-hamax*(hcode/hamax);
      31      if  hcode = 0  then  hcode = hamax-2;  end if; $ 0 code forbidden
      32      probes = 0;  j = 1;
      33
      34      while 1;
      35          if (probes > hamax) call ermey(3); $ ha is full-
      36          probes = probes + 1;
      37          j = j + hcode;  $ add original hashcode for next probe loc
      38          if  (j>hamax)  j = j - hamax;
      39          if  (ha_names ha(j) = 0)  quit while;  $ empty slot found
      40          if  (ha_len ha(j) ^= l)  cont while;
      41          do  i = 1 to tokwords; $ compare names
      42              if  (names(ha_names ha(j)+i-1) ^= ara(i)) cont while;
      43              end do;
      44          hap = j;
      45          return;
      46          end while;
      47
      48      $   add new name to ha.
      49      haused = haused + 1;
      50      ha_len ha(j) = l;    $ number of chars in name
      51      ha_names ha(j) = namesptr + 1;
      52      do  i = 1 to tokwords ;   $ enter name in names array
      53          countup(namesptr, namesmax, 'insert name');
      54          names(namesptr) = ara(i);
      55          end do;
      56      hap = j;
      57      end subr insnam;
       1 .=member ermet
       2      subr ermet; $  syntactic error message output procedure
       3
       4      $   report error number given by global ermsgno.  list current
       5      $   line, increment count, and terminate if error limit exceeded.
       6
       7      terml(yes);  $ give output to terminal too
       8      call lstlin;  $ list current line.
       9      nerrors = nerrors + 1;  $ update error count
      10      put ,error_notice;
      11
      12      if  ermsgno<1 ! ermsgno>parseerrmax  then
      13          go to e(0);
      14      else
      15          go to e(ermsgno) in 1 to parseerrmax;
      16          end if;
      17
      18      +*  et (erform, ertext) =
      19      call ermlst(erform, ertext); go to return; **
      20 / e( 0) /
      21      put ,'syntactic error number ' :ermsgno,i ,skip;
      22      go to return;
      23 / e( 1) /
      24      et('$definer', 'valid definer');
      25 / e( 2) /
      26      et('$<', '< before definer name');
      27 / e( 3) /
      28      et('< $name', 'definer name');
      29 / e( 4) /
      30      et('', '> after definer name');
      31 / e( 5) /
      32      et('= $definer', '');
      33 / e( 6) /
      34      et('=direct $/', '/ after direct part');
      35 / e( 7) /
      36      et('<* $name', 'name of lexical item');
      37 / e( 8) /
      38      et('<*name $>', '> after lexical name');
      39 / e( 9) /
      40      et('< $name', 'expect name after >');
      41 / e(10) /
      42      et('', '> after subpart name');
      43 / e(11) /
      44      et('', '> after subpart name');
      45 / e(12) /
      46      et('( act $)', 'parenthesis after action');
      47 / e(13) /
      48      et('+ $name', 'definer name');
      49 / e(14) /
      50      et('set $(', 'parenthesis after set');
      51 / e(15) /
      52      et('set( $int', 'register number');
      53 / e(16) /
      54      et('set(int $,', 'comma after register number');
      55 / e(17) /
      56      et('set(int , $int', 'integer');
      57 / e(18) /
      58      et('set(int , int $)', 'parenthesis to end set');
      59 / e(19) /
      60      et('m $(', 'parenthesis after m');
      61 / e(20) /
      62      et('m ( $int', 'integer for mark');
      63 / e(21) /
      64      et('m ( int $)', 'parenthesis to end mark op');
      65 / e(22) /
      66      et('- $int', 'error number');
      67 / e(23) /
      68      et('string $=', 'equal sign after string');
      69 / e(24) /
      70      et('string = $int','integer for option, lexmap or litmap');
      71 /return/;
      72      call toklist; $ list recent tokens
      73
      74      if  nerrors>pelvalue  then  $ quit if too many errors.
      75          put ,skip ,error_notice;
      76          put ,'error limit of ':pelvalue,i;
      77          put ,' exceeded. compilation aborted.' ,skip(2);
      78          call synexit(1);
      79          end if;
      80
      81      terml(no);  $ done with terminal output
      82      return;
      83      macdrop(parseerrmax)
      84      end subr ermet;  $  of syntactic error printer
      85
      86      subr ermlst(erform,ertext);  $ list error message fragment
      87
      88      $   this procedure, called only from ermes, lists part of syntacti
      89      $   error message.
      90      size  erform(ws+1);  $ text giving position in parse
      91      size  ertext(ws+1);  $ text for diagnostic
      92      if  .len. erform  then  put,'syntax '''; put:erform,a; put,''' ';
      93          end if;
      94      if  .len. ertext  then  $ if text.
      95          put, ' expect ': ertext, a;
      96          end if;
      97      put ,skip;
      98      end subr ermlst;
       1 .=member ermsg
       2      subr ermsg(n);  $ semantic error message procedure
       3      +*  ender = go to return;**
       4      +*  ernam = go to endwithname; **  $ end message with name.
       5      $   error message subprocedure
       6
       7      size  n(ps);  $ error number
       8
       9      terml(yes);  $ write error message to terminal file
      10      call lstlin;  $ list current line.
      11      if  n = 15   then   $ this is a warning
      12          put ,warning_notice;
      13          nwarnings = nwarnings + 1;
      14      else
      15          put,error_notice;
      16          nerrors = nerrors + 1;
      17          end if;
      18      +*  maxerrors = 20 **  $ maximum number of errors
      19      if (n < 1 ! n > maxerrors) go to l(1);
      20      go to l(n) in 1 to maxerrors;
      21      $   we allow room for up to maxerrors error messages
      22      $   unused slots branch to l(1), to list short text and number.
      23 / l( 1) /
      24      put ,'ermsg error number ':n,i; ender;
      25 / l( 2) /
      26      put ,'conditional branch to nonexistent next definer.'; ender;
      27 / l( 3) /
      28      put ,'redefining variable'; ernam;;
      29 / l( 4) /
      30      put ,'missing secondary item in definer.'; ender;
      31 / l( 5) /
      32      put ,'too many secondary items in definer.'; ender;
      33 / l( 6) /
      34      put ,'invalid register number.': ermsgarg,i; ender;
      35 / l( 7) /
      36      put ,'integer value out of range.': ermsgarg,i; ender;
      37 / l( 8) /
      38      put ,'undefined symbol used.'; ernam;;
      39 / l( 9) /
      40      put ,'undefined lexical item. '; ernam;;
      41 / l(10) /
      42      put ,'undefined literal. '; ernam;;
      43 / l(11) /  put ,'action string truncated.';  ender;
      44 / l(12) /
      45      put ,'name in use, cannot use for lexical '; ernam
      46 / l(13) /
      47      put ,'lexical code already assigned '; ernam;;
      48 / l(14) /
      49      put ,'name in use, cannot use for literal '; naml(ermsgarg);
      50          ender;
      51 / l(15) /
      52      put ,'literal code already assigned '; ernam;;
      53 / l(16) /
      54      put ,'name in use, cannot use for action. '; naml(ermsgarg);
      55          ender;
      56 / l(17) /
      57      put ,'lexical map not given for '; ernam;;
      58 / l(18) /
      59      put ,'literal map not given for '; ernam;;
      60 / l(19) /
      61      put ,'premature end of input forces termination.' ;ender;
      62 / l(20) /
      63      go to l(1);
      64 /endwithname/  $ put name of ha(ermsgarg).
      65      naml(ermsgarg);  ender;
      66 /return/
      67      put ,skip;
      68      call toklist; $ list recent tokens
      69      if  nerrors>pelvalue  then  $ quit if too many errors.
      70          put ,skip, error_notice;
      71          put ,'error limit of ': pelvalue, i;
      72          put ,' exceeded. run aborted.' ,skip(2);
      73          call synexit(1);
      74          end if;
      75      terml(no);  $ done with terminal output
      76      macdrop(maxerrors)  macdrop(ernam)
      77      end subr ermsg;
       1 .=member ermey
       2      subr ermey(n);  $ terminal error message procedure
       3      size  n(ps);  $ error number
       4
       5      terml(yes);  $ write output to terminal
       6      put ,system_notice;
       7      +*  maxerrors = 9 **
       8      if  (n < 1 ! n > maxerrors)  go to l(1);
       9      go to l(n) in 1 to maxerrors;
      10      +*  em = go to exit; **
      11 / l(1) /  put ,'fatal error number ' :n,i;  em;
      12 / l(2) /  put ,'parse control stack underflow'; em
      13 / l(3) /  put ,'symbol table full.'; em
      14 / l(4) /
      15 / l(5) /
      16 / l(6) /
      17 / l(7) /
      18 / l(8) /
      19      go to l(1);
      20 / l(9) /  put ,'bad token lexical type'; em
      21      macdrop(em)  macdrop(maxerrors)
      22 /exit/
      23      put ,skip;  call toklist;
      24      terml(no);  $ done with output to terminal
      25      call synexit(1);  $ abort - fatal error
      26      end subr ermey;
      27
       1 .=member gnam
       2      subr gnam;  $ process definer name, start definer.
       3
       4      if  jumpnext  then     $ there is a missing next direct item
       5          jumpnext = 0;
       6          call ermsg(2);
       7          end if;
       8
       9      if  ha_pt ha(arg)  then    $ name already defined
      10          ermsgarg = arg;
      11          call ermsg(3);
      12          return;
      13          end if;
      14
      15      ha_pt ha(arg) = ptablim + 1;
      16
      17      $   see if 'error' clause which is target of error check.
      18      if  (ha_synlc ha(arg) = lc_error)  errloc = ptablim + 1;
dsd   21      if  setlopt  then
dse    8          if  (ha_synlc ha(arg) = lc_errmp)  errmploc = ptablim + 1;
dsd   23          end if;
      19      end subr gnam;
       1 .=member gdir
       2      subr gdir;  $ begin direct part.
       3 $ if there are forward references to this rule, indicated
       4 $ by nonzero jumpnext, set ha_pt to current ptab entry
       5
       6
       7      defptr = 0;    $ reset deftab pointer.
       8
       9      if  jumpnext  then
      10          ha_pt ha(jumpnext) = ptablim + 1;
      11          jumpnext = 0;
      12          end if;
      13      end subr gdir;
       1 .=member galt
       2      subr galt;  $ process alternate part.
       3
       4 $ merge primtab and sectab into ptab.
       5 $ check that there are the correct number of secondary items.
       6
       7      size  pp(ps);   $ primtab temp pointer
       8      size  sp(ps);   $ sectab temp pointer
       9      size  op(ps);   $ parse opcode
      10      size  sop(ps);  $ secodary item opcode
      11
      12      definertot = definertot + 1;  $ number of definers
      13      pp = 1;   $ primary pointer
      14      sp = secptr;   $ secondary pointer
      15      while pp < secptr;
      16          op = parse_op deftab(pp);   $ check to see if op requires sec
      17          countup(ptablim, ptabmax, 'ptab');
      18          ptab(ptablim) = deftab(pp);
      19          if  op=op_lex ! op=op_lit ! op=op_sub  then
      20              if  sp > defptr  then
      21                  call ermsg(4); $ no more secondary
      22                  return;
      23                  end if;
      24          sop = parse_op deftab(sp);   $ check for op_set operation,
      25                              $ in which case the secondary
      26                              $ consists of two items
      27
      28          countup(ptablim, ptabmax, 'ptab');
      29          ptab(ptablim) = deftab(sp);
      30          sp = sp + 1;
      31          if  sop = op_set  then
      32              countup(ptablim, ptabmax, 'ptab');
      33              ptab(ptablim) = deftab(sp);
      34              sp = sp + 1;
      35              end if;
      36          end if;
      37          pp = pp + 1;   $ prim tab pointer
      38          end while;
      39
      40      if  (sp <= defptr)  call ermsg(5);    $ too many secondaries
      41
      42      $   if direct part ends with jmp, can omit bak after direct part.
      43      if  secptr>1  then  $ if direct part not empty.
      44          if  (parse_op deftab(secptr-1) = op_jmp)  return;
      45          end if;
      46
      47      parseskel = 0;
      48      parse_op parseskel = op_bak;
      49      countup(ptablim, ptabmax, 'ptab');
      50      ptab(ptablim) = parseskel;
      51      end subr galt;
       1 .=member glex
       2      subr glex;  $ process <*name> - lexical.
       3      size  hap(ps);    $ ha index.
       4
       5      hap = arg;
       6      call setmtyp(hap, mtyp_lex);
       7
       8      if  ha_mtyp ha(hap) ^= mtyp_lex  then  $ if wrong type.
       9          ermsgarg = hap;  call ermsg(12);
      10          end if;
      11
      12      if  ha_mval ha(hap) = 0  then  $ if need new count.
      13          if  lexmapflag   then  $ if missing map value.
      14              ermsgarg = hap;  call ermsg(17);
      15          else  $ if syn is to assign.
      16              mtyptot(mtyp_lex) = mtyptot(mtyp_lex) + 1;
      17              ha_mval ha(hap) = mtyptot(mtyp_lex);
      18              if  (ha_len ha(hap)>lexlenmax) lexlenmax = ha_len ha(hap);
      19              end if;
      20          end if;
      21
      22      emitop(op_lex, hap);
      23      end subr glex;
       1 .=member glit
       2      subr glit;  $ process literal.'
       3
       4      size  hap(ps);    $ ha index.
       5
       6      hap = arg;
       7      call setmtyp(hap, mtyp_lit);
       8
       9      if  ha_mtyp ha(hap) ^= mtyp_lit  then  $ if wrong type.
      10          ermsgarg = hap;  call ermsg(12);
      11          end if;
      12
      13      if  ha_mval ha(hap) = 0  then  $ if need new count.
      14          if  litmapflag   then  $ if missing map value.
      15              ermsgarg = hap;  call ermsg(17);
      16          else  $ if syn is to assign..
      17              mtyptot(mtyp_lit) = mtyptot(mtyp_lit) + 1;
      18              ha_mval ha(hap) = mtyptot(mtyp_lit);
      19              if  (ha_len ha(hap)>litlenmax) litlenmax = ha_len ha(hap);
      20              end if;
      21          end if;
      22
      23      emitop(op_lit, hap);
      24      end subr glit;
       1 .=member gact
       2      subr gact;  $ process action.
       3
       4      size  parenct(ps);    $ parenthesis counter
       5      size  i(ps);
       6      size  lcnow(ps);    $ current length of code string.
       7      size  lcnew(ps);    $ new length of code string.
       8      size  hap(ps);  $ ha index of generated item.
       9      size  codestr(.sds. toklenmax);  $ code string.
      10      size  ln(ps);   $ length of current token.
      11
      12      codestr = '' .pad. toklenmax;
      13      .len. codestr = 0;
      14      parenct = 1;   $ have parsed one left paren
      15
      16      while 1;
      17          call nextok;   $ get next token
      18          if  (toklc = lc_lparen)  parenct = parenct + 1;
      19          if  (toklc = lc_rparen)  parenct = parenct - 1;
      20          if  (parenct = 0)  quit while;
      21          keeptok = no;   $ accept token.
      22          $   append current token and blank to codestr.
      23          lcnow = .len. codestr;
      24          ln = .len. insnamstr;
      25          lcnew = lcnow + ln + 1;
      26          assert lcnew <= toklenmax;
      27          .len. codestr = lcnew;
      28          .s. 1+lcnow, ln+1, codestr = insnamstr;
      29          end while;
      30
      31      keeptok = yes;   $ reject token.
      32      .len. codestr = (.len. codestr) - 1;  $ eliminate last blank.
      33      .len. insnamstr = .len. codestr;
      34      .s. 1, (.len. codestr), insnamstr = codestr;
      35      call insnam(hap);
      36      call setmtyp(hap, mtyp_act);  $ set to action type.
      37      if  ha_mtyp ha(hap) ^= mtyp_act  then  $ if wrong type.
      38          ermsgarg = hap;  call ermsg(16);
      39          return;
      40          end if;
      41
      42      if  ha_mval ha(hap) = 0  then  $ if need new code.
      43          mtyptot(mtyp_act) = mtyptot(mtyp_act) + 1;
      44          ha_mval ha(hap) = mtyptot(mtyp_act);
      45          end if;
      46      emitop(op_act, hap);   $ emit op_act item
      47      end subr gact;
       1 .=member gset
       2      subr gset;  $ process set operation.
       3
       4 $ emit a set_op. int1 stores register number
       5 $ and -ival- stores value
       6
       7      if  int1 > 8 ! int1<1  then
       8          ermsgarg = int1;  call ermsg(6);
       9          return;
      10          end if;
      11      if  ival > maxint  then
      12          ermsgarg = ival; call ermsg(7);
      13          return;
      14          end if;
      15
      16      parseskel = 0;
      17      parse_op parseskel = op_set;
      18      parse_parm1 parseskel = int1 - 1;
      19      parse_parm2 parseskel = ival;
      20      countup(defptr, deftabdim, 'deftab');
      21      deftab(defptr) = parseskel;
      22      end subr gset;
       1 .=member ptlist
       2      subr ptlist;  $ list pt.
       3
       4
       5      size  i(ps);   $ do loop variable
       6      size  op(ps);  $ opcode
       7      size  prm(ps); $ parse parameter
       8      size  pti(ps);     $ loop index.
       9      size  oper(ps);    $ op value.
      10      size  parm(ps);    $ parm value.
      11      size  isalab(ptabmax);  $ bit i on if ptab(i) defines label.
      12      size isxlab(ptabmax);  $ to record extra label definitions.
      13
      14
      15      +*  lamax = 200  **  $ maximum label count for list.
      16      size  laha(ps);  dims laha(lamax);
      17      size  lapt(ps);  dims lapt(lamax);
      18      size  laptr(ps);  $ la index.
      19      size  hex4(.sds. 4);   $ convert to 4 hex digits.
      20      size  name8(.sds. 8);  $ give first 8 chars of name.
      21      size  lai(ps), li(ps);   $ la indexes.
      22      size  res4(.sds. 4);  $ resolves pt entry into string.
      23      size  ent(ps);   $ copy of ptab entry.
      24
      25      call stitlr(1, 'parse table list.');
      26      put ,page;
      27
      28      $   mark label points.
      29      laptr = 0;
      30      isalab = 0;
      31
      32      do  i = 1 to hamax;
      33          if  ha_pt ha(i)  then  $ if label.
      34              .f. ha_pt ha(i), 1, isalab = yes;
      35              countup(laptr, lamax, 'la');
      36              laha(laptr) = i;
      37              lapt(laptr) = ha_pt ha(i);
      38              end if;
      39          end do;
      40
      41      isxlab = 0;
      42      do  i = 1 to haxtrap;
      43          if  ha_pt ha(i+hamax)  then  $ if extra label.
      44              .f. ha_pt ha(i+hamax), 1, isxlab = 1;
      45              end if;
      46          end do;
      47
      48      put ,skip;
      49
      50      do  i = 1 to ptablim;
      51          op = parse_op ptab(i);
      52          prm = parse_parm ptab(i);
      53          ent = ptab(i);
      54          put ,x(2) :hex4(i),a(4), x(2); $ pt index in hex.
      55          put :res4(i),a(4);
      56          put ,x(2) :i,i(5) ,x(2);
      57          lai = 0;  $ set nonzero if is label definition.
      58          if  .f. i, 1, isalab  then  $ if label.
      59              do  li = 1 to laptr;
      60                  if  lapt(li) = i  then  $ if found.
      61                      lai = li;
      62                      quit do;
      63                      end if;
      64                  end do;
      65              end if;
      66          if  lai  then  $ if label.
      67              put :name8(laha(lai)),a(8);
      68          elseif  .f. i, 1, isxlab  then  $ if extra label.
      69              put ,'-' ,x(7);
      70          else
      71              put ,x(8);
      72              end if;
      73
      74          put ,x(2) :opnames(op+1),a(3);
      75
      76      go to l(op) in 1 to 15;
      77      /l(op_bak)/
      78          go to el;
      79      /l(op_set)/
      80              put :(parse_parm1 ptab(i)+1),i(5) ,' ='
      81                  :(parse_parm2 ptab(i)),i;
      82              go to el;
      83      /l(op_err)/  /l(op_op1)/  /l(op_op2)/  /l(op_op3)/
      84      /l(op_op4)/  /l(op_op5)/
      85              put :prm,i(5) ,x(3);
      86              go to el;
      87      /l(op_act)/  /l(op_lex)/  /l(op_lit)/
      88              $ if need to list mval.
      89              put :(ha_mval ha(prm)),i(5) ,x(3);
      90              naml(prm);
      91              go to el;
      92      /l(op_jif)/  /l(op_jmp)/  /l(op_sev)/  /l(op_sub)/
      93              $   if need parse table index.
      94              put :(ha_pt ha(prm)),i(5) ,x(3);
      95              if  (prm<=hamax)  then  naml(prm);  end if;
      96      /el/;
      97
      98          put ,skip;
      99          end do;
     100      call stitlr(1, ' ');  $ clear subtitle.
     101      put ,skip;
     102      end subr ptlist;
       1 .=member res4
       2      fnct res4(pti);  $ resolve ptab entry.
       3
       4      size  pti(ps);   $ ptab index.
       5      size  op(ps);    $ parse op.
       6      size  prm(ps);   $ parameter field.
       7      size  ent(ps);   $ resolved value.
       8      size  res4(.sds. 4);  $ function value.
       9      size  hex4(.sds. 4);  $ converts entry to hex string.
      10
      11
      12      op = parse_op ptab(pti);
      13      prm = parse_parm ptab(pti);
      14      ent = ptab(pti);
      15      go to l(op) in 1 to 15;
      16 /l(op_bak)/  /l(op_err)/  /l(op_op1)/  /l(op_op2)/
      17 /l(op_op3)/  /l(op_op4)/  /l(op_op5)/  /l(op_set)/
      18      res4 = hex4(ent);
dsc   18      go to ret;
      20
      21 /l(op_act)/  /l(op_lex)/  /l(op_lit)/
      22      parse_parm ent = ha_mval ha(prm);
      23      res4 = hex4(ent);
dsc   19      go to ret;
      25
      26 /l(op_jif)/  /l(op_jmp)/  /l(op_sev)/  /l(op_sub)/
      27          $   resolve pt label.
      28      if  ha_pt ha(prm)  then  $ if resolved.
      29          parse_parm ent = ha_pt ha(prm);
      30          res4 = hex4(ent);
      31      else  $ if unresolved.
      32          res4 = hex4(ent);  .s. 1, 3, res4 = '***';
      33          end if;
dsc   20 /ret/   $ here to return, set res4ent to binary value.
dsc   21      res4ent = ent;
      34      end fnct res4;
       1 .=member name8
       2      fnct name8(hap);  $ put first 8 chars of name.
       3
       4      size  name8(.sds. 8);
       5      size  hap(ps);      $ ha index.
       6      size  l(ps);      $ name length.
       7
       8      name8 = ''.pad.8;
       9      if  (hap=0)  return;
      10      call sdsnamr(hap);
      11      l = ha_len ha(hap);
      12      if  (l>8) l=8;
      13      .s. 1, l, name8 = sdsnamstr;
      14      end fnct name8;
       1 .=member ptout
       2      subr ptout;  $ write out parse table.
       3
       4      size  i(ps);
       5      size  j(ps);
       6      size  nl(ps);   $ number of items per line printed.
       7      size  cpl(ps);      $ constants per line.
       8      size  pti(ps);      $ parse table index.
       9      size  li(ps);       $ line index.
      10      size  ci(ps);       $ constant index.
      11      size  ei(ps);       $ entry index.
      12      size  hex4(.sds. 4); $ hex conversion function.
      13      size  res4(.sds. 4);  $ converts pt entry to string.
      14      size  hap(ps);   $ ha index.
      15      size  s3(.sds. 3);      $ implicit macro string.
dsc   22      size  s4(.sds.4);       $ work string.
      16
      17      +*  pup = put parsefile **
      18
      19      call putmem(0, 'tab');
      20
      21      $   write out parse table as series of byte constants.  put a
      22      $   comma or blank after each constant so can read using l
      23      $   mode format, and put a semicolon after last constant so can
      24      $   use as body of data statement.  put a sequence field on each
      25      $   line.
      26
      27      assert (epc>=1) & (epc<=10);
      28      cpl = 60 / (10 + 5*(epc-1));
      29      if  (cpl=0)  cpl = 1;
      30      $   round up ptablim to be multiple of epc.
      31      ptablimout = epc * ((ptablim + epc-1) / epc);
      32
      33      do  i = ptablim+1 to ptablimout;  ptab(i) = 0;  end do;
      34
      35      pti = 0;  $ index in ptab of entry.
      36
      37      do  li = 1 to ptablimout/(epc*cpl) + 1;
      38          pup ,x(5);  $ start line.
      39          do  ci = 1 to cpl;  $ for each constant.
      40              pup ,' 4b''';  $ begin constant.
      41              do  ei = 1 to epc;  $ for each entry in constant.
      42                  pti = pti + 1;  $ next ptab entry.
      43                  if  pti <= ptablim  then  $ if actual parse op.
      44                      pup :res4(pti),a(4);
      45                  else  $ if rounding out table.
      46                      pup ,'0000';
      47                      end if;
      48                  if  ei < epc  then  $ if need blank after constant.
      49                      pup ,x;
      50                      end if;
      51                  end do ei;
      52              if  pti = ptablimout  then  $ if last constant.
      53                  pup ,''' ;';  quit do ci;
      54                  end if;
      55              pup ,''',';
      56              end do ci;
      57          pup ,column(67) ,'$' :li,i(4) ,skip;  $ sequence field.
      58          if  (pti=ptablimout)  quit do;
      59          end do li;
      60
      61      pup ,skip;
      62
      63      call putmem(1, 'tab');
      64
      65      call putmem(0, 'mac');
      66
      67      pup ,' $ syn run on ' :timestr,a ,skip(2);
      68      call putmac('aramax', ptablimout);
      69      call putmac('litaramax', mtyptot(mtyp_lit));
      70      call putmac('lexaramax', mtyptot(mtyp_lex));
      71      call putmac('actmax', mtyptot(mtyp_act));
      72      if  errloc  then    $ write location of error recovery
      73          call putmac('errloc', errloc);
      74          end if;
dse    9      if  setlopt>0 & errmploc>0  then  $ write location of errmp symbol
dse   10          call putmac('errmploc', errmploc);
dsd   26          end if;
      75      call putmac('errmax', errmax);
dsh   10      if setlopt  then  $ if want count of implicit macros.
dsh   11          do  i = 1 to 26;
dsh   12              if  (imara(i) = 0)  cont do;
dsh   13              j = imara(i);  $ get map type.
dsh   14              s3 = 'im ';  .ch. 3, s3 = .ch. i, alphabet;  $ find name.
dsh   15              li = 0;  $ li counts number of entries.
dsh   16              hap = mtyporg(j);
dsh   17              while hap;
dsh   18                  li = li + 1;
dsh   19                  hap = ha_next ha(hap);
dsh   20                  end while;
dsh   21              call putmac(s3.cc.'max', li);
dsh   22              end do;
dsh   23          end if;
      76      call putmem(1, 'mac');
      77
      78      call putmem(0, 'lex');
      79
      80      hap = mtyporg(mtyp_lex);
      81      while hap;
      82          call sdsnamr(hap);  $ get name of lexical item.
      83          pup ,x(6) ,'synlexmap(' :sdsnamstr,al;
      84          if  filestat(parsefile,column) < 30 then
      85              pup ,column(30);
      86              end if;
      87          pup ,',' :(ha_mval ha(hap)),i(4) ,')' ,skip;
      88          hap = ha_next ha(hap);
      89          end while;
      90
      91      call putmem(1, 'lex');
      92
dse   11      if  setlopt  then  $ if want member giving number of literals.
dse   12          call putmem(0, 'max');
dse   13          i = 0;
dse   14          hap = mtyporg(mtyp_lit);
dse   15          while hap;
dse   16              i = i + 1;
dse   17              hap = ha_next ha(hap);
dse   18              end while;
dse   19          call putmac('litmax', i);
dse   20          call putmem(1, 'max');
dse   21          end if;
dse   22
      93      call putmem(0, 'lit');
      94
      95      hap = mtyporg(mtyp_lit);
      96      while hap;
      97          call sdsnamr(hap);  $ get name of lexical item.
      98          pup ,x(6) ,'synlitmap(' :sdsnamstr,al;
      99          if  filestat(parsefile,column) < 30 then
     100              pup ,column(30);
     101              end if;
     102          pup ,',' :(ha_mval ha(hap)),i(4) ,')' ,skip;
     103          hap = ha_next ha(hap);
     104          end while;
     105
     106      call putmem(1, 'lit');
     107
     108      $   write out actions.
     109
     110      call putmem(0, 'act');
     111
     112      hap = mtyporg(mtyp_act);
     113      while hap;
     114          pup ,' / pa(' :(ha_mval ha(hap)),i(4), ') / ';
     115          call sdsnamr(hap);
     116          if  .ch. 1, sdsnamstr = 1r-  then  $ if no want call
     117              pup  :(.s. 2, .len. sdsnamstr-1, sdsnamstr),a ,';';
     118          else
     119              pup ,' call ' :sdsnamstr,a ,';';
     120              end if;
     121          if  ('- go to ' .in. sdsnamstr) = 1  then $ if go to.
     122              pup ,skip;
     123          else  $ if need pac macro after generator.
     124              if  filestat(parsefile,column) < 65  then
     125                  pup ,column(65);
     126                  end if;
     127              pup ,' pac;' ,skip;;
     128              end if;
     129          hap = ha_next ha(hap);
     130          end while;
     131
     132      call putmem(1, 'act');
     133
     134      $put out members for any implicit macros.
     135      do  i = 1 to 26;
     136          if  (imara(i) = 0)  cont do;
     137          j = imara(i);  $ get map type.
     138          s3 = 'im ';  .ch. 3, s3 = .ch. i, alphabet;  $ find name.
     139          call putmem(0, s3);  $ start member.
     140          hap = mtyporg(j);
     141          while hap;
     142              call sdsnamr(hap);  $ get name.
     143              pup ,x(6) ,'syn' :s3,a(3) ,'map(' :sdsnamstr,a;
     144              if  filestat(parsefile, column) < 30  then
     145                  pup ,column(30);
     146                  end if;
     147              pup ,',' :(ha_mval ha(hap)),i(4) ,')' ,skip;
     148              hap = ha_next ha(hap);
     149              end while;
     150          call putmem(1, s3);  $ end member.
dsc   23          if  setlopt  then  $ if setl option, write 'mark' map.
dsc   24              call putmem(0, 'mark');  $ start member.
dsc   25              hap = mtyporg(j);
dsc   26              while hap;
dsc   27                  call sdsnamr(hap);  $ get name.
dsc   28                  pup ,x(6) ,'syn' :'mark',a(4) ,'map(' :sdsnamstr,a;
dsc   29                  if  filestat(parsefile, column) < 30  then
dsc   30                      pup ,column(30);
dsc   31                      end if;
dsc   32                  pup ,', ''' :.s.3,(.len.sdsnamstr-2),sdsnamstr,a
dsc   33                      ,''')' ,skip;
dsc   34                  hap = ha_next ha(hap);
dsc   35                  end while;
dsc   36              call putmem(1, 'mark');  $ end member.
dsc   37              end if setlopt;
dsc   38
dsc   39          if  setlopt  then  $ if setl option, write 'sem' map.
dsc   40              call putmem(0, 'sem');  $ start member.
dsc   41              hap = mtyporg(j);
dsc   42              while hap;
dsc   43                  call sdsnamr(hap);  $ get name.
dsc   44                  pup ,x(6) ,'syn' :'sem',a(3) ,'map(' :sdsnamstr,a;
dsc   45                  if  filestat(parsefile, column) < 30  then
dsc   46                      pup ,column(30);
dsc   47                      end if;
dse   23                  pup ,', g' :.s.3,(.len.sdsnamstr-2),sdsnamstr,a
dsc   49                      ,')' ,skip;
dsc   50                  hap = ha_next ha(hap);
dsc   51                  end while;
dsc   52              call putmem(1, 'sem');  $ end member.
dsc   53              end if setlopt;
dsc   54
     151          end do;
     152
dsf   26      if  (asmtype^=0)  call ptasm;  $ if want assembler text.
dsc   55      $   if setl option and no errors, write binary file.
dsc   56      if  setlopt  & (nerrors=0)  then
dsi   28          file binfile access=write ,title=binfilename;
dsc   58          do  i = 1 to ptablimout;
dse   24              if  (i>ptablim)  cont do;
dsc   59              s4 = res4(i);  $ resolve entry.
dsc   60              ptab(i) = res4ent;  $ convert to resolved binary.
dsc   61              end do;
dsc   62          write binfile, ptab(1) to ptab(ptablimout);
dsf   27          file binfile access=release;
dsc   63          end if;
     153      macdrop(pup)
     154      end subr ptout;
       1 .=member ptasm
       2      subr ptasm;  $ write parse table data in assembler format.
       3 $    write parse table to unit 6 in form appropriate for target
       4 $    machine, according to machine used or value of tm= program
       5 $    parameter.  write the parse table as follows
       6 $    1.  initial line (machine-dependent)
       7 $    2.  ptbeg macro call, operand is dimension
       8 $    3.  series of  ptval  macro calls
       9 $    4.  ptend macro call
      10 $    5.  final line (machine-dependent)
      11 $    for example, for cdc 6600 (s66), little code corresponding to
      12 $
      13 $        subr ptinit;
      14 $        nameset nsptab;
      15 $        size pt(.ws.); dims pt(3); data pt = 10, 20, 30;
      16 $        end nameset;
      17 $        end subr;
      18 $
      19 $    yields
      20 $
      21 $        ident   ptinit
      22 $        ptbeg   3
      23 $        ptval   10
      24 $        ptval   20
      25 $        ptval   30
      26 $        ptend
      27 $        end
      28 $
      29 $    operators begin in column 9 and operands in column 17 if possible.
      30
      31      size  i(.ps.);          $ loop index.
      32      size  res4(.sds. 4);    $ function value.
      33      size  s4(.sds. 4);      $ holds string resul of res4 call.
      34      size  ptv(ws);          $ binary value of parse table entry.
      35
dsi   29      file asmfile access=put, title=asmfilename, linesize=80;
      37
      38      if  asmtype = 10  then  $ if s10.
dsg    8          put asmfile ,column(9) ,'search  synmac' ,skip;
      40      elseif  asmtype = 32  then  $ if s32
      41          put asmfile ,column(9) ,'.title' ,column(17) ,'ptinit' ,skip;
      42      elseif  asmtype = 37  then  $ if s37
      43          ;  $ no initial line required for s37.
      44      elseif  asmtype = 66  then  $ if s66
      45          put asmfile ,column(9) ,'ident' ,column(17) ,'ptinit' ,skip;
      46      end if;
      47      put asmfile ,column(9) ,'ptbeg'
      48          ,column(17) :ptablimout,i ,skip;
      49      do  i = 1 to ptablimout;
      50          if  i<=ptablim  then  $ if nonzero entry.
      51              s4 = res4(i);  $ resolve entry.
      52              ptv = res4ent;  $ get binary value.
      53          else  ptv = 0;  end if;
dsi   30          put asmfile ,column(9) ,'ptval' ,column(17)
dsi   31              :(.f. 1, parsesz, ptv),i ,skip;
      55          end do;
      56      put asmfile ,column(9) ,'ptend' ,skip;
      57
      58 $    write terminal line according to target machine.
      59      if  asmtype = 10  then  $ if s10.
      60          put asmfile ,column(9) ,'end' ,skip;
      61      elseif  asmtype = 32  then  $ if s32.
      62          put asmfile ,column(9) ,'.end' ,skip;
      63      elseif  asmtype = 37  then  $ if s37.
      64          put asmfile ,column(9) ,'end' ,skip;
      65      elseif  asmtype = 66  then  $ if s66.
      66          put asmfile ,column(9) ,'end' ,skip;
      67          end if;
      68      file asmfile access=release;
      69      end subr ptasm;
       1 .=member putmac
       2      subr putmac(lab, val);  $ put macro definition to parse file.
       3      size  lab(.sds. 10);  $ macro name.
       4      size  val(ws);        $ value to put.
       5
       6      put parsefile ,x(6) ,'+*  ' :macroprefix,a :lab,a
       7          ,' = ' :val,i ,' **' ,skip;
       8      end subr putmac;
       1 .=member putmem
       2      subr putmem(c, str);  $ put member descriptor to parse file.
       3      size  c(1);   $ zero for start, one for end.
       4      size  str(.sds.3);  $ member suffix.
       5
       6      if  c = 0  then  $ if starting member.
       7          put parsefile ,' .=member ' :memberprefix,a :str,a ,skip
       8              ,' $ member ' :memberprefix,a :str,a ,skip;
       9      elseif c = 1  then  $ if ending member.
      10          put parsefile ,' $ end member ' :memberprefix,a :str,a ,skip;
      11      else  assert 0=1;  $ if invalid case.
      12          end if;
      13      end subr putmem;
      14      fnct hex4(v);  $ convert to four hex digits.
      15
      16      size  v(ws);
      17      size  hex4(.sds. 4);
      18      size  i(ps);  $ byte index.
      19      size  j(ps);  $ temporary.
      20
      21      hex4 = ''.pad.4;
      22      do  i = 1 to 4;
      23          j = .f. 17-i*4, 4, v;
      24          .ch. i, hex4 = hexcharofdig(j);
      25          end do;
      26      end fnct hex4;
       1 .=member halist
       2      subr halist;  $ list ha.
       3
       4      size  i(ps);
       5
       6      call stitlr(1, '');  $ clear subtitle.
       7      call etitlr(1, '-ha-', 2, 4);
       8      call etitlr(1,
       9     'mtyp  mval  next islbl synlc   len names    pt  symbol',
      10        10,65);
      11      put ,page;
      12
      13      do  i = 1 to hamax;
      14          if  (ha_names ha(i) = 0)  cont do;
      15          put  :i  :ha_mtyp ha(i)  :ha_mval ha(i)  :ha_next ha(i)
      16              :ha_islbl ha(i)  :ha_synlc ha(i)
      17              :ha_len ha(i)  :ha_names ha(i)  :ha_pt ha(i) ,i(6) ,x(2);
      18          call sdsnamr(i);
      19          put :sdsnamstr,a(40);
      20          put ,skip;
      21          end do;
      22
      23      put ,skip ,'ha chain origins: '
      24          :mtyporg(mtyp_act),i(6) ,' act'
      25          :mtyporg(mtyp_lex),i(6) ,' lex'
      26          :mtyporg(mtyp_im1),i(6) ,' im1'
      27          :mtyporg(mtyp_im2),i(6) ,' im2'
      28          :mtyporg(mtyp_im3),i(6) ,' im3'
      29          :mtyporg(mtyp_im4),i(6) ,' im4'  ,skip(4);
      30      call stitlr(1, '');  $ clear subtitle.
      31      call etitlr(1, '', 10, 65);  $ clear subtitle.
      32      end subr halist;
       1 .=member synexit
       2      subr synexit(exitcode);  $ generator phase exit procedure
       3      $   if -exitcode- is non-zero, abnormal end is indicated,
       4      $   0 indicates normal exit.
       5      $   collects statistics, signs off, etc.
       6
       7      size  exitcode(ps);  $ exit code
       8      size  i(ps);            $ do loop index
       9      size  iorc(ps);         $ io return code.
      10      size  p(ps);    $ ptab pointer
      11      size  ploc(ps);  $ relocation address
      12      size  hdr(ps);   $ header printed flag
      13      size  j(ps);    $ do loop index
      14      size  op(ps);  $ parse tab op.
      15      size  hap(ps);      $ ha index.
      16
      17      call clossio(tokenfile, iorc);
      18
      19
      20      $   check that labels defined.
      21      hdr = no;
      22      do  i = 1 to ptablim;
      23          op = parse_op ptab(i);
      24          if  op=op_jif ! op=op_jmp ! op=op_sev ! op=op_sub  then
      25              ploc = ha_pt ha(parse_parm ptab(i));
      26              if  ploc = 0  then    $ if undefined label.
      27                  nerrors = nerrors + 1;
      28                  j = parse_parm ptab(i);
      29                  if  hdr = no  then  $ if need header.
      30                      hdr = yes;
      31                      put ,'error - undefined labels: ';
      32                      end if;
      33                  if  j<=hamax  then  naml(j); put ,x;  end if;
      34                  if  filestat(2, column) > lastcol  then
      35                      put ,skip ,x(6);
      36                      end if;
      37                  end if;
      38              end if;
      39          end do;
      40
      41      if  (hdr)  put ,skip;
      42
      43 $ check for label defined but not used (possible error)
      44      do  i = 1 to hamax;
      45          if  ha_islbl ha(i) = 0 & ha_pt ha(i)
      46              & ha_synlc ha(i) ^= lc_error  then
      47              put ,skip ,'label defined and not used: ';
      48              naml(i);  put ,skip;
      49          end if;
      50      end do;
      51
      52      call stitlr(1, 'statistics for syn run.');
      53
      54      put ,page;
      55      put ,'number of lexicals is' :mtypnum(mtyp_lex),i(5) ,'.' ,skip
      56          ,'number of literals is' :mtypnum(mtyp_lit),i(5) ,'.' ,skip
      57          ,'number of actions  is' :mtypnum(mtyp_act),i(5) ,'.' ,skip
      58          ,'length of generated parse table is' :ptablim,i(5)
      59          ,'.' ,skip;
      60
      61      errmax = (.fb. errbit - 1)/2 + 1; $ maximum
      62                     $ error number used.
      63      put ,'largest error message number is' :errmax,i(5) ,'.' ,skip;
      64
      65
      66 $ check error numbers
      67      hdr = no;   $ print header
      68      do  i = 1 to errmax;
      69          if  errbits(i) = 0  then
      70              if  hdr = no  then  $ print header
      71                  hdr = yes;   $ only print header once
      72                  put ,'error numbers not used:';
      73                  end if;
      74              if  filestat(2, column) > lastcol  then
      75                  put ,skip ,x(10);
      76                  end if;
      77              put :i,i(4);
      78              end if;
      79          end do;
      80
      81      if  (hdr)  put ,skip;
      82
      83      put ,skip;
      84
      85 $ check for error numbers reused
      86      hdr = no;
      87      do  i = 1 to errmax;
      88          if  errbits(i) = 2  then
      89              if  hdr = no  then
      90                  put ,'multiple use of error numbers:' ,x(2);
      91                  hdr = yes;
      92                  end if;
      93              if  filestat(2, column)>60  then
      94                  put ,skip ,x(10);
      95                  end if;
      96              put :i,i(4);
      97              end if;
      98          end do;
      99      put ,skip;
     100
     101 $      print lexical and literal maps
     102      put ,skip ,'lexical map used in parse table.' ,skip(2);
     103      hap = mtyporg(mtyp_lex);
     104
     105      while  hap;
     106          put ,x(6) :(ha_mval ha(hap)),i(5) ,x(2);
     107          naml(hap);
     108          put ,skip;
     109          hap = ha_next ha(hap);
     110          end while;
     111
     112      put ,skip;
     113      put ,skip ,'literal map used in parse table.' ,skip(2);
     114      hap = mtyporg(mtyp_lit);
     115
     116      while  hap;
     117          put ,x(6) :(ha_mval ha(hap)),i(5) ,x(2);
     118          naml(hap);
     119          put ,skip;
     120          hap = ha_next ha(hap);
     121          end while;
     122
     123      put ,skip;
     124      terml(yes);  $ this goes to terminal
     125      if  nerrors  then
     126          put :nerrors,i ,' errors detected by syn.' ,skip;
     127      else
     128          listl(no); put ,'no detected errors.';
     129          put ,skip; listl(yes);
     130          end if;
     131      terml(no);   $ end of terminal listing
     132
     133      if  (halistflag)  call halist;
     134
     135      if  (listpt)  call ptlist;
     136
     137      call ptout;
     138
     139      if  exitcode  then  $ if abnormal termination.
     140          terml(yes);
     141          put ,error_notice;
     142          put ,'abnormal program termination.' ,skip;
     143      else  $ if normal terminatinon.
     144          put ,skip ,'end of syn run.' ,skip(2);
     145          end if;
     146      terml(no); call clsterm;  $ close terminal file
     147      call ltlfin(exitcode, (nwarnings^=0) *4 + (nerrors^=0) * 8);
     148      end subr synexit;
« November 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
 

Powered by Plone CMS, the Open Source Content Management System

This site conforms to the following standards: