Personal tools
You are here: Home Projects SETL SETL Source code SEM: Semantic pass; second pass of the SET compiler.
Document Actions

SEM: Semantic pass; second pass of the SET compiler.

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

SEM: Semantic pass; second pass of the SET compiler. stlsem.opl

       1 .=member intro
       2$           ssssssss   eeeeeeeeee  tttttttttt  ll
       3$          ssssssssss  eeeeeeeeee  tttttttttt  ll
       4$          ss      ss  ee              tt      ll
       5$          ss          ee              tt      ll
       6$          sssssssss   eeeeee          tt      ll
       7$           sssssssss  eeeeee          tt      ll
       8$                  ss  ee              tt      ll
       9$          ss      ss  ee              tt      ll
      10$          ssssssssss  eeeeeeeee       tt      llllllllll
      11$           ssssssss   eeeeeeeee       tt      llllllllll
      12$
      13$
      14$                 ssssssss   eeeeeeeeee  mm      mm
      15$                ssssssssss  eeeeeeeeee  mmm    mmm
      16$                ss      ss  ee          mmmm  mmmm
      17$                ss          ee          mm mmmm mm
      18$                sssssssss   eeeeee      mm  mm  mm
      19$                 sssssssss  eeeeee      mm  mm  mm
      20$                        ss  ee          mm      mm
      21$                ss      ss  ee          mm      mm
      22$                ssssssssss  eeeeeeeeee  mm      mm
      23$                 ssssssss   eeeeeeeeee  mm      mm
      24$
      25$
      26$          t h e    s e t l    s e m a n t i c    p a s s
      27$
      28$       this software is part of the setl programming system
      29$                address queries and comments to
      30$
      31$                          setl project
      32$                 department of computer science
      33$                      new york university
      34$           courant institute of mathematical sciences
      35$                       251 mercer street
      36$                      new york, ny  10012
      37$
      38
      39
      40$ this is the second or semantic pass of the setl compiler. it
      41$ translates the polish string produced by the parser into an
      42$ internal form known as 'q1' which is used to drive the
      43$ optimizer.
      44
      45$ many of the data structures used in the semantic pass are
      46$ specified in the introduction to the optimizer. we recommend
      47$ that the user read these comments before continuing.
      48
      49$ basic design considerations
      50$ ---------------------------
      51
      52$ there are three problem areas in compiling setl. these have motivated
      53$ most of the design decisions in the semantic pass.
      54$
      55$ 1. loop constructs
      56$
      57$    setl contains a variety of unusual loop constructs. for
      58$    example the statement
      59$
      60$        s1 = << x+1 : x in s st c(x) >>;
      61$
      62$    involves a loop over 's' to build 's1'. the code for 'x+1'
      63$    is actually part of the loop body, even though it comes
      64$    befoe the actual loop specification. thus we cannot
      65$    generate code for this statement by scanning the program
      66$    in a strictly left-right order.
      67$
      68$    here is another example of the same problem:
      69$
      70$        loop    init  open(input);
      71$                doing read x;
      72$                while x /= nil
      73$                term  print 'end of file found'; close(input);
      74$        do
      75$
      76$                s with x;
      77$                s1 with x+1;
      78$        end;
      79$
      80$    in this case the loop body comes after the loop specification.
      81$    however the loop specification includes a block of code which
      82$    is performed at the end of the loop. once again we cannot
      83$    emit code in left-right order.
      84$
      85$    one solution to this problem is to have the parser build
      86$    a tree, then write a clever tree-walk routine which does
      87$    not necessarily process the descendents of each node in
      88$    left-right order. this solution is elegent, but requires
      89$    mutually recursive routines, something hard to imitate
      90$    in little.
      91$
      92$    the other solution is to emit code in left-right order
      93$    saving a pointer to the place where the loop body should
      94$    go, then move the body into place once we have finally
      95$    processed the whole loop.
      96$
      97$    this second solution turns out to be quite comfortable,
      98$    particularly since we must emit the code as a list anyway.
      99$    it also allows the parser to produce the tree in a very
     100$    straight forward depth-first left-right ordering, i.e.
     101$    reverse polish notation.
     102$
     103$    the exact mechanism for moving code is discussed in the
     104$    next section.
     105$
     106$ 2. assignments and left hand sides
     107$
     108$    the second problem area is the treatment of assignments and
     109$    left hand sides. let us examine the following on the fly
     110$    assignment:
     111$
     112$        f(x+1, y) := p(a, b)
     113$
     114$    two problems arise here. first of all, when we see 'f(x+1, y)'
     115$    we do not know whether it is a retrieval operation or a left
     116$    hand side. thus we do not know what code to generate for it.
     117$
     118$    second, it may be that 'p' is a function which modifies 'x'
     119$    and 'y'. in order to make the program meaningful in this case,
     120$    we require that the right hand side of an assignment always
     121$    be evaluated before the left hand side. this is another
     122$    case where code motion is required.
     123$
     124$    we encounter another problem with multiple assignments, i.e.
     125$
     126$        [ [a, b], [c, d] ] := e;
     127$
     128$    here we must assign 'e' to some temporary, then assign its
     129$    components to two other temporaries, and finally assign their
     130$    components to a, b, c, and d. in order to generate the
     131$    outer assignments first, we must do some kind of top
     132$    down tree traversal.
     133$
     134$    in order to process assignments, we first build trees
     135$    for their left and right hand sides, then walk these trees top
     136$    down. the trees themselves are built by a rather simple
     137$    method: we emit q1 code for both the left and right hand
     138$    sides, building a map from each temporary to the instruction
     139$    which defines it. this map allows us to walk q1 as if it
     140$    were a tree.
     141$
     142$    a list of instructions is called a 'code fragment'. each code
     143$    fragment is identified by two pointers:
     144$
     145$    prev:    pointer to instruction before fragment
     146$    last:    pointer to last instruction
     147$
     148$    each temporary can be thought of as being the result of a code
     149$    fragment. we provide two maps on temporaries which are used
     150$    to identify their code fragment, known as tprev and tlast.
     151$    if 't' is a temporary, then tlast(t) is not only the end of
     152$    its code fragment, but points to the instruction which
     153$    actually generates 't'.
     154$
     155$ 3. separate compilations
     156$
     157$    a setl program consists of a set of 'members'. these members
     158$    may be compiled together or separately.
     159$
     160$    the compiler has between one and three input files:
     161$
     162$    a. the source for the current compilation. this file
     163$       contains one or more members, sorted do that each
     164$       library and directory staticly preceeds all members
     165$       which reference it.
     166$
     167$    b. a file containing the results of zero or more previous
     168$       compilations. this file is refered to as the binder file.
     169$
     170$    c. a file containing the left justified blank terminated
     171$       names of additional 'binder' files which should be processed
     172$       after the first binder file.
     173$
     174$    the semantic pass begins by merging the binder file into
     175$    its output file, leaving all relavent symbols in the
     176$    symbol table. it then processes all new members contained
     177$    on the input file. it aborts if it finds either a previously
     178$    compiled member or a reference to a library or directory
     179$    which has not already been seen on either the input or
     180$    binder file.
     181
     182
       1 .=member mods
       2
       3
       4$ program revision history
       5$ ------------------------
       6
       7$ this section contains a description of each revision to the program.
       8$ these descriptions have the following format:
       9$
      10$ mm-dd-yy      jdate     author(s)
      11$
      12$ 1.............15........25............................................
      13$
      14$ where mm-dd-yy are the month, day, and year, and jdate is the julian
      15$ date.
      16$
      17$ each time a revision is installed, the author should insert a
      18$ description after line 'mods.21', and change the macro 'prog_level'
      19$ to the current julian date.
      20$
      21$ ......................................................................
bnda   1
bnda   2
bnda   3$ 01/07/85     85007     s. freudenberger
bnda   4$
bnda   5$  1. hash non-primitive constants.
bnda   6$     modules affected: genst, gcase4, and msyms.
bnda   7$  2. make all val-table local to the scope of the symbol.
bnda   8$     modules affected: gcnst1 and ginit.
bnda   9$  3. set the ft_deref field correctly.
bnda  10$     modules affected: gtpref and mforms.
bnda  11$  4. improve the error messages for invalid -integer lo..hi- repr.
bnda  12$     modules affected: gtint and ermsg.
sunb   1
sunb   2
sunb   3$ 07/24/84     84206     s. freudenberger
sunb   4$
sunb   5$  1. introduce program parameters -lcp- and -lcs- to control default
sunb   6$     output:  -lcp- controls the listing of program parameters, i.e.
sunb   7$     the initial phase heading;  -lcs- controls the listing of the
sunb   8$     final statistics.  if both are set, the old listing is generated;
sunb   9$     if neither is set, no output is generated unless an error occurs.
sunb  10$     modules affected: start, semini, and semtrm.
suna   1
suna   2
suna   3$ 02/05/84     84065     s. freudenberger
suna   4$
suna   5$  1. support motorola mc68000 microprocessor on sun workstation.
suna   6$     modules affected: start, semini, and binder.
suna   7$  2. correct a sizing error in the form hashing routines.
suna   8$     modules affected: hashf1 and hashf2.
suna   9$  3. move all q1_stmt quadruples between an unconditional goto and the
suna  10$     end of the basic block before the unconditional goto.
suna  11$     module affected:  blkdec.
suna  12$  4. handle f_gen correctly when checking procedures for based
suna  13$     arguments.
suna  14$     module affected:  isfbsd.
smfd   1
smfd   2
smfd   3$ 09/01/83     83244     s. freudenberger
smfd   4$
smfd   5$  1. correct the is_back flag setting for temporaries in boolean
smfd   6$     expressions.
smfd   7$     module affected:  gbin.
smfd   8$  2. use the new short integer binary file format.
smfd   9$     module affected:  putsbi.
smfe   1$  3. correct the termination test during the jump table expansion for
smfe   2$     the case statement.
smfe   3$     module affected:  gcase4.
smfe   4$  4. modify the loop generators to allow the folding of while, where,
smfe   5$     and until clauses.  the new code integrates boolean results.
smfe   6$     modules affected: gunivq, gwhile, gwhere, guntil, and movblk.
smfe   7$  5. correct the constant folding of the mod function.
smfe   8$     module affected:  fldbin.
smfc   1
smfc   2
smfc   3$ 09/01/83     83244     s. freudenberger
smfc   4$
smfc   5$  1. document and adjust the machine-dependency of integer represen-
smfc   6$     tation in setl binary i/o.
smfc   7$     modules affected: start and putsbi.
smfc   8$  2. remove the warning message for ambiguous map reprs.
smfc   9$     modules affected: gtmap1 and warn.
smfb   1
smfb   2
smfb   3$ 08/08/83     83220     s. freudenberger
smfb   4$
smfb   5$  1. improve mode propagation and code generated for arithmetic
smfb   6$     iterators.  include form checks as appropriate.
smfb   7$     modules affected: start, garith, fndinc, ermsg, and dblock.
smfb   8$  2. generate better code for boolean operations.  this includes the
smfb   9$     introduction of a new stack, called bstack, and three new opcodes,
smfb  10$     q1_pos, q1_bif, and q1_bifnot (boolean if and ifnot).
smfb  11$     modules affected: start, gstat, gif2, gbin, gun, and dblock.
smfb  12$     module added:     gbool (after gbin).
smfb  13$  2. increase the limit of the control statement stack, cstack.
smfb  14$     module affected:  start.
smfb  15$  3. add a new conditional branch, q1_ifasrt, with the semantics to
smfb  16$     branch to a1 if getipp('assert=1/2') = 0.
smfb  17$     modules affected: start and dblock.
smfb  18$     module deleted:   gasrt.
smfb  19$     modules added:    gasrt1, gasrt2, and gasrt3.
smfb  20$  4. increase the size of the rpr_flag for the reprs program parameter.
smfb  21$     the old reprs=1 corresponds to the new reprs >= 1, to allow
smfb  22$     addition of the reprs program parameter in cod.
smfb  23$     modules affected: start, grepr, gcase4, and gputtb.
smfb  24$  5. correct the declaration for 'close'.
smfb  25$     module affected:  inbip1.
smfb  26$  6. correct the code for -writes all ;- to give only read-access to
smfb  27$     constants.  also, print an error message for -libraries all ;-.
smfb  28$     modules affected: ghead4 and ermsg.
smfb  29$  7. change the name generated for the return value of a routine from
smfb  30$     'g$name' to 'name(..)'.  this improves the readability of messages
smfb  31$     generated by the optimiser.
smfb  32$     module affected:  prcdcl.
smfb  33$  8. insert missing re-initialisation of code table so that the binder
smfb  34$     works properly.
smfb  35$     modules affected: gdef1 and blkdec.
smfb  36$  9. include a check for previously declared user-defined labels to
smfb  37$     asure that the name actually is a label.
smfb  38$     module affected:  glabel.
smfb  39$ 10. generate a separate call block for each user-defined procedure to
smfb  40$     to avoid having to do this in the optimiser.
smfb  41$     module affected:  gcall.
smfb  42$ 11. modify the gasn routine to eliminate the type check on parallel
smfb  43$     assignments.
smfb  44$     module affected:  gasn.
smfb  45$ 12. include the code to generate case tuples.
smfb  46$     modules affected: gcase4, ermsg, and warn.
smfb  47$ 14. include a check for zero divisor into the fold-binary routine.
smfb  48$     modules affected: fldbin and ermsg.
smfa   1
smfa   2
smfa   3$ 12/16/82     82350     s. freudenberger
smfa   4$
smfa   5$  1. correct the initialisation of the standard form f_pair.
smfa   6$     module affected:  inisym.
smfa   7$  2. correct the setting of the ft_deref field for local, base, and
smfa   8$     element-of-base forms.
smfa   9$     modules affected: useloc, gbase1, and hashf1.
smfa  10$  3. check that we actually find a loop to continue or quit on cstack.
smfa  11$     modules affected: gcont, gquit, and findlp.
      22
      23
      24$ 08/12/82     82224     s. freudenberger
      25$
      26$  1. string pattern sets have been defined as a separate entity.  they
      27$     are (still) represented as packed tuples, but are parameterised
      28$     to generate byte tables for r32.  the necessary form f_pset is
      29$     generated.
      30$     module affected:  inisym.
      31$  2. the form table layout has been changed:  the fields 'ft_deref' and
      32$     'ft_imset' have been added, and are set as appropriate.
      33$     modules affected: inform, gtmap1, hashf1, hashf2, sputtb, mforms,
      34$                       and fmdump.
      35$  3. we postpone the check for constant expressions to the semantic
      36$     pass, and are thus able to constant fold additional operators.
      37$     module affected:  gint, greal, gstr, fldbin, foldun, and ermsg.
      38$     modules deleted:  gsnint and gsreal.
      39$  4. error messages were corrected.
      40$     modules affected: findlp and ermsg.
      41$  5. variables aliased to sym_true and sym_false were incorrectly
      42$     written onto the sq1 file.
      43$     module affected:  sputtb.
      44$  6. getint builds a (signed) denotation from the value and hashes it
      45$     into the symbol table.  before it merely allocated an internal
      46$     constant.
      47$     module affected:  getint.
      48$  7. the form of user-defined labels is correctly set.
      49$     module affected:  glabel.
      50
      51
      52$ 06/15/82     82166     s. freudenberger
      53$
      54$  1. we count the 'case  of' of a case statement as a separate
      55$     statement.
      56$     module affected:  (remote text inclusion)
      57
      58
      59$ 06/01/82     82152     s. freudenberger
      60$
      61$  1. we added conditional code for the s37 mts implementation.
      62$     module affected:  semini.
      63$  2. we distinguish, for better diagnostics, inconsistent repr'ing and
      64$     attempts to repr formal parameters without repr'ing the associated
      65$     procedure.
      66$     modules affected: grepr and ermsg.
      67$  3. we initialise and use the ft_low form table field, to hold i, the
      68$     minimum value of a 'integer i..j' mode.  this makes the ft_nonzero
      69$     field superfluous, which hence has been deleted from the setl q1
      70$     file.
      71$     modules affected: gtpref, gtint, sputtb, and fmdump.
      72$  4. the keyword 'map' is back in the language:  first code additions
      73$     have been made to support this repr.
      74$     modules affected: start, gtmap1, and warn. (warn is temporary.)
      75$  5. an error introduced with the last correction set has been
      76$     corrected.
      77$     module affected:  gdef.
      78$  6. 'gendr1', which is called at the end of a scope before the tables
      79$     are written out, has been modified to give better diagnostics for
      80$     missing procedures/perform blocks.
      81$     module affected:  gendr1.
      82$  7. the interation variable of an arithmetic iterator is set to omega
      83$     in the term block.
      84$     module affected:  garith.
      85$  8. 'chkvar' now diagnoses an error whenever an implicit declaration
      86$     for a non-local variable is attempted.
      87$     module affected:  chkvar.
      88$  9. the dimension of ctab has been quadrupled to 100.
      89$     module affected:  copy.
      90$ 10. several error message texts were found to be dead, and were
      91$     changed to null strings.
      92$     module affected:  ermsg.
      93$ 11. the mixed-tuple-table dump routine has been rewritten to produce a
      94$     more compact listing.
      95$     module affected:  mtdump.
      96$ 12. the error message format of the 'overfl' routine has been changed
      97$     to the format used by the 'ermsg' routine.
      98$     module affected:  overfl.
      99
     100
     101$ 03/16/82     82075     s. freudenberger
     102$
     103$  1. a program parameter has been added which allows warnings to be
     104$     printed for each unrepr'ed variable.  these warnings are only
     105$     issued if reprs=1 is specified as well.  this work required to
     106$     revisit the setting of the is_repr flag, to assure its correct
     107$     setting.
     108$     new program parameter:
     109$         ur=0/1        print warnings for unrepr'ed variables whenever
     110$                        reprs=1 is specified
     111$     modules affected: start, semini, gmemb, ghead7, prcdcl, ginit,
     112$                       rproc, gmode, gputtb, and warn.
     113$  2. the default value of the 'reprs' program parameter has been
     114$     changed to 'reprs=1/1', expressing our increased confidence into
     115$     this feature.
     116$     module affected:  semini.
     117$  3. the keyword 'map' has been reserved again, to be used eventually
     118$     for ambiguous map declarations.
     119$     module affected:  inisym.
     120$  4. the name for the main procedure has been changed from s$main to
     121$     _main.
     122$     modules affected: inisym and getglb.
     123$  5. the return value for the eof build-in function has been corrected
     124$     to f_atom from f_string.
     125$     module affected:  inbip1 and inibip3.
     126$  6. we allow the syntax 'procedure () ' to declare the return
     127$     mode of a parameterless procedure.  to this end, we added the new
     128$     type processing routine gtprc4.
     129$     module added:     gtprc4 (after gtprc3).
     130$  7. the <*name> after library, directory, and program is checked to be
     131$     in the local scope.  otherwise the member's value is not written
     132$     with its scope.  this change is needed for partial compilation as
     133$     well as for the optimiser.  we also check the <*name>'s of proce-
     134$     dures.
     135$     modules affected: gdirct, gprog3, glib, prcdcl, and ermsg.
     136$  8. the symbol table flags is_proc, is_memb, and is_base have been
     137$     replaced by test on the ft_type of the symbol's form.  this change
     138$     modified the sq1- and q1 file formats.
     139$     modules affected: gmemb, ghead7, prcdcl, gbase1, gplex, sputtb,
     140$                       and msyms.
     141$  9. the symbol table flag is_rec has been made part of the sq1- and
     142$     q1-files, so that it can be set by the optimiser.  this change
     143$     modified the sq1- and q1 file formats.
     144$     modules affected: prcdcl, sputtb, and msyms.
     145$ 10. a new symbol table flag is_init has been added to flag initialised
     146$     variables.  this flag is part of the sq1- and q1-files, hence
     147$     modified the sq1- and q1 file formats.  this change removes all
     148$     restrictions from the use of init declarations.
     149$     modules affected: ginit, grepr, sputtb, msyms, and symdmp.
     150$ 11. the form table field ft_low has been made part of the sq1 file,
     151$     hence modified the sq1 file format.
     152$     module affected:  sputtb.
     153$ 12. up to now, we never really checked for read-access of a variable:
     154$     this has been changed.  for the time being, we merely print a
     155$     warning message if we use a non-local variable without having
     156$     read-access.  eventually, this will be changed to an error.
     157$     module affected: gdef, chkvar, ermsg, and warn.
     158$ 13. we suppress the generation of an internal variable for compound
     159$     operators on tuples in the binary form.
     160$     module affected:  gcomp5.
     161
     162
     163$ 02/01/82     82032     s. freudenberger
     164$
     165$  1. the listing output has been moved to start each line in column 1
     166$     rather than column 7.  dump outputs have not been modified.
     167$     modules affected: semini, ermsg, warn, overfl, semtrm, and usratp.
     168$  2. the line layout for error and warning messages has been modified.
     169$     modules affected: ermsg and warn.
     170$  3. arithmetic iterators emit code to bypass the loop body if the
     171$     increment (decrement) of the loop control variable is zero.
     172$     before, such a loop would be infinite.
     173$     modules affected: garith and fndinc.
     174$  4. gnexst has been added to emit code for the 'notexists' quantifier.
     175$     module added:     gnexst (after exist).
     176$  5. gtint now sets the ft_low field for 'integer low .. high' modes.
     177$     this field is not yet used, yet should replace the ft_nonzero
     178$     eventually.
     179$     module affected:  gtint.
     180
     181
     182$ 02/01/82    82032     d. shields
     183$
     184$ use r32 conditional symbol for standard 32-bit fields.
     185$ this replaces the field definitions for s32, s37 and s47.
     186
     187
     188$ 01/15/82     82015     s. freudenberger
     189$
     190$  1. semini has been modified to print the phase header to the terminal
     191$     whenever the new control card parameter 'termh=0/1' is set.
     192$     new control card parameter:
     193$         termh=0/1           print phase header on the terminal file
     194$     module affected:  semini.
     195$  2. gcase4 has been modified to always declare the case map as an s-ma
     196$     regardless of the reprs control card parameter.
     197$     module affected:  gcase4.
     198$  3. fix problem in statement number generation (gmprog).
     199
     200
     201$ 11/29/81    81333     d.shields
     202$
     203$  1. support s47: amdahl uts (universal timesharing system).
     204$     this implementation runs on s37 architecture using an operating
     205$     system very close to unix (v7), and uses the ascii character set.
     206
     207
     208$ 10/27/81     81300     s. freudenberger
     209$
     210$  1. the setl-fortran interface has been implemented for the
     211$     s32, s37, and s66 versions.
     212$     the interface uses a communication area which is kept as a
     213$     tuple in the setl heap as the symbol intf:  sym_intf replaces
     214$     sym_spare1.
     215$     the actual call to fortran is done by the new built-in function
     216$     callf, for which a new q1 symbol table entry was needed.
     217$     modules affected: inisym and inibip1.
     218$  2. the reserved words 'spec' and 'unspec' have been deleted.
     219$     modules affected: inisym and inibip1.
     220
     221
     222$ 06/24/81     81175     s. freudenberger
     223$
     224$  1. a third argument has been added to the q1_free instruction to
     225$     specify the argument number.  this is needed because otherwise
     226$     the code generator can not determine when to free the skip word
     227$     of an untyped parameter.
     228$     modules affected: start and gcall.
     229$  2. the compiler debugging options rtrs0 and rtrs1 have been dropped.
     230$     the runtime statement trace can be control using trace statements
     231$     and notrace statements
     232$     module affected:  inisym.
     233$  3. we initialise the symbol table entries for s$ovar, s$scopes,
     234$     s$rnspec, and s$rnames.  (see compl for a more detailed account
     235$     on what these entries are used for.)
     236$     module affected:  inisym.
     237$  4. the inbip1 routine has been modified to account for the change
     238$     that the setl open function returns a boolean, indicating the
     239$     success or failure of this operation.
     240$  5. when we see a program or module statement, we check that it has
     241$     been declared in the directory.
     242$     modules affected: gprog2, gprog3, gmod2, and ermsg.
     243$  6. we now allow simple programs to access libraries.
     244$     module affected:  ghead6.
     245$  7. we set the is_memb flag when we have seen a  in the
     246$     input.  this allows us to detect missing members in a separate
     247$     compilation.
     248$     module affected:  ghead7.
     249$  8. there was some confusion about the sequence of imports and
     250$     exports lists.  this has been taken care of.
     251$     modules affected: sethd and gendm.
     252$  9. we reset curmemb to curdir at the end of a non-library member.
     253$     module affected:  gendm.
     254$ 10. the gcnst1 and ginit routines have been modified to set the
     255$     is_decl flag of the generated internal variable.
     256$ 11. the gcnst1 and ginit routines have been modified to copy only the
     257$     val entries of values not in the current scope.
     258$ 12. formal paramaters are implicitly repred by the procedure decla-
     259$     ration.  in particular, if the procedure is not repred, they
     260$     are implicitly repred to have the mode general.  this is now
     261$     checked properly.
     262$     module affected:  grepr.
     263$ 13. local set types based on plex bases must be initialiased in a
     264$     static scope with an init statement.  this requirement is now
     265$     tested for.
     266$     module affected:  grepr.
     267$ 14. only based smaps can have untyped ranges.  we perform the requi-
     268$     red test now.
     269$     module affected:  grepr.
     270$ 15. we changed the allocation for named constants of mode f_elmt so
     271$     that their name depends on the name of the variable it was gene-
     272$     rated from.  this reduces the number of internal variables re-
     273$     alocated during binding.
     274$     modules affected:  rconst, rinit, and genelt.
     275$ 16. we implemented case map optimisation for the case when the case
     276$     expression is an element of a base.
     277$     module affected:  gcase4
     278$ 17. the gdomi routine has been modified so that the iterator
     279$     variable (t2) is checked for omega, rather than the domain
     280$     value (t3).
     281$ 18. the table overflow check in readpg has been corrected.  it did
     282$     check the bias instead of the lower bound of the array slice
     283$     being read.
     284$ 19. we changed the file format of the sq1 file:  constants of mode
     285$     f_atom must be the booleans true and false (or symbol table
     286$     entries aliased to these two).  the sq1 entry for such a constant
     287$     now is, indeed, a boolean.
     288$     module affected:  sputtb.
     289
     290$  08/20/81   81232   s. tihor
     291$
     292$   1.  expand the s32 polish file word format.
     293$   2.  expand proctab for ada compiler.
     294$   3.  increase the limit on real denotationss.
     295
     296
     297$  04/02/81     80092     s. tihor
     298$
     299$   1.  add symbol table support for 20 space variables.  the addition
     300$       while motivated by the psetl variant work is part of the
     301$       general change to a production quality compiler footing.
     302
     303
     304$ 08/30/80    80252     s. tihor
     305$
     306$  1. add the ibind parameter which gives the name of a file
     307$     of left justified file names which are to be treated as bind
     308$     files successively.
     309$  2. add code to read files in.
     310$  3. alter gcnst and ginit proc to copy their value table entries
     311$     into the val table slice that correspondes to the current
     312$     symtab slice.
     313$  4. increase proctab_lim by 100 to 200 for ada.
     314$  5. check in greal for bad number (overflow, etc.)
     315$  6. get name of terminal file from little.
     316
     317
     318$ 12/02/80     80337     s. freudenberger
     319$
     320$  1. 'cstmt_count', the cummulative statement counter, and
     321$     'ustmt_count', the cstmt_count at the start of the current
     322$     compilation unit, have been initialized to zero (rather
     323$     than one).  they are incremented now in gstat1 before they
     324$     are used, thus giving different cstmt-counts for the last
     325$     statement of the previous unit and the first statement of
     326$     the current unit.
     327
     328
     329$ 11/05/80     80310     s. freudenberger
     330$
     331$  1. the string comparisons of the file titles in semini has been
     332$     corrected to use the .seq. operator, and not bit string
     333$     equality.
     334$  2. the standard form f_uset does not set the is_neltok bit
     335$     anymore.
     336$  3. semtrm has been modified to write an additional zero for
     337$     the q1 tail record.  this is a consequence of change (2)
     338$     recorded on 07/08/80 (80190).
     339$  4. packed integer ranges have been restricted to exclude zero.
     340$     this was necessary because the pack key for the range
     341$     integer i .. j stores the integer i-1:  for i=0, this would
     342$     mean that we attempt to store -1.
     343$  5. for remote objects, the test that they are not based on a
     344$     plex base has been moved so that it will cover remote sets
     345$     as well.
     346$  6. the form dump routine (fmdump) has been updated to reflect
     347$     the form table changes described in compl.
     348
     349
     350$ 09/08/80     80252     s. freudenberger
     351$
     352$  1. the hash table header arrays for the symbol- and form tables
     353$     have been increased for s32 and s37.
     354$  2. the hash table header array for the form table has been moved
     355$     into member start.  the nameset fheads has been eliminated.
     356$  3. the form table entry for f_pair is initialized to zero.
     357
     358
     359$ 08/18/80     80231     s. freudenberger
     360$
     361$  1. the mode prefix map is initialized completely.
     362$  2. for set formers, the code sequence emitted for  has been
     363$     changed for the case where  is not temporary:
     364$     the result of  always is a temporary.
     365$     this change has been made to facilitate the handling of set
     366$     formers in the optimizer.
     367$  3. the bind file read statement has been corrected to reflect
     368$     the recent q1 file format change.
     369
     370
     371$ 08/01/80     80214     s. freudenberger
     372$
     373$  1. the gasn routine has been re-visited to special case an
     374$     optimization:  if a routine returns a tuple, it is assigned
     375$     to a temporary, which has form general, which would mean
     376$     a type check.  in this case, however, we like to propagate
     377$     the proper form onto the internal variable generated to
     378$     replace the temporary.  this is done now.
     379$  2. the new conditional assembly member of compl replaces the
     380$     section 'conditional assembly' of member start.
     381
     382
     383$ 07/10/80     80192     s. freudenberger
     384$
     385$  1. a new q1 opcode has been introduced:  q1_error.  it is emitted
     386$     in procedure scopes whenever an error is diagnosed, and whenever
     387$     the parser signaled an error.
     388$  2. the line "parse error limit..." is not echoed to the terminal
     389$     anymore.
     390
     391
     392$ 07/09/80     80191     s. freudenberger
     393$
     394$ a dependency on the grammar and ltlsyn output has been parameterized.
     395
     396
     397$ 07/08/80     80190     s. freudenberger
     398$
     399$  1. the end of both the polish and auxiliary polish files are
     400$     marked by a special polish node.  the driver routine checks
     401$     for this special node to terminate.
     402$  2. once again, efforts have been made to synchronize statement
     403$     numbers between the parser, semantic pass, code generator,
     404$     and the run-time library.  this time it is done by recording
     405$     the cummulative statement number of the q1_entry instruction so
     406$     that the code generator can insert the proper statement number
     407$     into the statement quadruples.
     408$  3. the semantic of compound assignments has been made more precise:
     409$     the right-hand side must be a tuple.  the only exception occurs
     410$     in the seti and domi routines, where we like to assign omega to
     411$     the iteration variables.  these assignments are special cased in
     412$     the gasn routine, and a flag (a new third parameter) marks this
     413$     case.
     414$  4. the tprev pointer for the temporary used in the code sequence
     415$     generated for the query operator (-?-) is set properly.
     416$  5. the line "no errors..." is not echoed to the terminal anymore.
     417$  6. the layout of the title line has been changed.
     418
     419
     420$ 06/20/80     80172     s. freudenberger
     421$
     422$  1. a bug related to the global string specifiers has been corrected.
     423$  2. the gasn routine has been modified so that is does not generate
     424$     the check for omega if the right-hand side is known to be a tuple.
     425
     426
     427$ 05/27/80     80148     s. freudenberger
     428$
     429$  1. the nelt field of the embedded tuple of a remote map is not
     430$     maintained.  consequently the ft_neltok flag must not be set.
     431
     432
     433$ 05/09/80     80130     s. freudenberger
     434$
     435$  1. the last correction set misplaced some lines conditioned to s10.
     436$     these lines are hereby deleted.
     437$  2. we now allow omegas in constants.  the result of constant folding
     438$     on [ [om, 1] ] is f_uset, as [om, 1] is not a pair.
     439$  3. 'gasn' has been modified to diagnose constant right hand sides
     440$     correctly in '[x, y, ..., z] := const'.
     441$  4. a new global flag has been added to control the processing of
     442$     user-supplied representation statements: rpr_flag.  this flag
     443$     can be set via the new reprs control card parameter.
     444$  5. the code sequence generated for the query operator has been
     445$     changed to suppress evaluation of the right operand if the
     446$     left operand is not omega.  the q1_query operator has been
     447$     eliminated.
     448$  6. the standard symbol is_primitive and the q1_isprim operator
     449$     have been eliminated.
     450
     451
     452$ 04/11/80     80102     d. shields
     453
     454$ 1. increase astack limit for s32 - this needed for lalr and
     455$    ada work. other implementations desiring to use these
     456$    products should be adjusted accordingly.
     457$ 2. delete cdc update yankdeck directives.
     458$ 3. avoid use of '0' null file. this needed since s10 env does
     459$    not support this, and code conditioned by s10.
     460
     461
     462
     463$ 04/09/80     80100     s. freudenberger
     464$
     465$ 1. the gasn routine has been modified to produce correct code for
     466$         (/ x1, ..., xn /) := om;
     467$ 2. the gseti and gdomi routines have been modified to set all
     468$    iteration variables to omega, as specified in the semantic
     469$    definition of setl.
     470$ 3. an equality test in the getglb routine has been corrected to
     471$    check character string equality rather then bitstring equality.
     472$ 4. the binder routine msyms has been modified to read constants
     473$    a little more efficiently.
     474
     475
     476$ 02/04/80     80035     s. freudenberger and d. shields
     477$
     478$ 1. implement unary operators acos, asin, atan, char, cos, exp,
     479$    log, sin, sqrt, tan and tanh.
     480$ 2. implement binary operators atan2 and interrogation (?).
     481$ 3. implement type predicates is_atom, is_boolean, is_integer,
     482$    is_map, is_real, is_set, is_string and is_tuple.
     483$    change prim to is_primitive.
     484$ 4. add procedure host() to provide means for adding
     485$    implementation- or site-dependent features.
     486$ 5. the argument to q1_stmt (the cummulative statement count) has
     487$    been dropped.
     488$ 6. an attemt to repr a variable with a procedure-, member-, or label-
     489$    form now produces an error message (actually, only the first of
     490$    the three possibilities is of importance...)
     491$ 7. the 'fold unary operator' routine (foldun) has been corrected
     492$    to use correctly sized variables.
     493
     494
     495$ 01/21/80     80021     s. freudenberger
     496$
     497$ the form table limit has been increased for s32.
     498
     499
     500$ 01/16/80     80016     s. freudenberger
     501$
     502$ 1. 'gsin' has been modified to suppress the generation of an
     503$    internal variable for the last retrieval operation, since
     504$    this operation is deleted anyway.
     505$ 2. 'gcall' has been updated as to allow assignment of a write-
     506$    parameter to a read-only parameter of the inclosing scope.
     507
     508
     509$ 01/15/80     80015     s. freudenberger
     510$
     511$ the semantic routines for signed numeric constants have been changed
     512$ to create a new val entry.
     513
     514
     515$ 12/17/79     79351     s. freudenberger
     516$
     517$ 1. conditional assembly 'sq1' has been introduced to conditionally
     518$    assemble the setl q1 interface.
     519$ 2. the semantic of the 'quit' statement has been changed:  quit does
     520$    not execute the term block, but rather branches to a label imme-
     521$    diately after the term block.
     522$ 3. domain iterators set the range- and domain elements to omega upon
     523$    completion of the iteration.
     524$ 4. the semantic routines for signed numeric constants have been
     525$    changed to create a new symbol table entry.
     526
     527
     528$ 11/30/79     79334     s. freudenberger
     529$
     530$ 1. 'gsin' has been corercted to handle <*name>
     531$    correctly.  problem due to improper temporary handling.
     532$ 2. the error message for case map overflow has been improved, and will
     533$    now state 'too many cases' as opposed to 'settup'.
     534$ 3. 'gseti' has been corrected to emit a code sequence which supports
     535$    repr's.  problem due to final q2_locate before test for termination
     536$ 4. 'foldst' now checks for both too many values and omegas before
     537$    constant folding takes place.
     538$ 5. on compiler table overflow it is now possible to print the compiler
     539$    tables using the 'et' (error trace) control card parameter.
     540
     541
     542$ 11/12/79     79316     s. freudenberger
     543$
     544$ 1. mode keyword 'map' has been dropped.  the related grammar changes
     545$    have been reflected in the semantic routines 'gtmap2' (has been
     546$    deleted), 'gtmmap' (has been updated), 'gtmmp1'  'gtmmp2' (have
     547$    been added).
     548$ 2. the 'dump' control card parameter has been replaced by the
     549$    'sq1sd' and 'sq1cd' parameters, thus avoiding the name conflict
     550$    with the 'dump' parameter of lib and dmp.
     551$ 3. 'sif' has been introduced as a new control card parameter.  it
     552$    control whether intermediate files are to be saved.
     553$    files affected are the pol- and xpol-files.
     554$ 4. 'pre_flag', which used to indicate prefix-stropping, has been
     555$    eliminated.
     556$ 5. the map_code mapping has been dropped.  (it had become trivial)
     557$ 6. decks 'insn', 'settup', and 'copy' have been updated to use the
     558$    'nargs_lim' macro (defined in cmnpl.q1symtab)
     559$ 7. the setl binary i/o interface has been re-done.  it is now
     560$    consistent with the optimizer interfaces and the code generator
     561$    setl binary i/o interface.
     562$ 8. the decks 'gsnint' and 'gsreal' have been added.  they perform the
     563$    semantic actions corresponding to signed numeric constants.
     564$ 9. the unit_xxx codes have been corrected.
     565
     566
     567$ 09/27/79     79269     s. freudenberger
     568$
     569$ 1. the binder has been put back into operation.
     570$ 2. a blank is printed after the variable name in a warning message.
     571
     572
     573$ 09/17/79     79259     s. freudenberger
     574$
     575$ 1. all procedure and function names have been shortened to at most
     576$    six alphamerics.
     577
     578
     579$ 09/13/79     79256     s. freudenberger
     580$
     581$ 1. 'gcnst2' has been modified to process 'const id;' correctly.
     582$ 2. 'sethd' has been modified to print an error messages if an
     583$    undeclared identifier appears in a reads or writes list.
     584$ 3. logical file names are sized using 'filenamlen' (defined in
     585$    cmnpl.sysmac).
     586$ 4. 'gcall1' has been modified to check for calls to perform blocks.
     587$    this required the addition of 'gcall3', to distinct between
     588$    '<*name> ;' and '<*name> ( ) ;'.
     589
     590
     591$ 09/05/79     79248     s. freudenberger
     592$
     593$
     594$ this correction set installs setl 2.1
     595$
     596$
     597$  1. 'opmap' and 'q1tab' have been changed and amended.
     598$  2. two tables have been added: 'mode_map' maps mode keywords to
     599$     predefined modes.  'tuple_type' and 'map_type' map element
     600$     forms to the corresponding tuple- and map-forms.
     601$  3. 'true' and 'false' are two new system constants.
     602$  4. '//' is now written as 'mod'.
     603$  5. two new string primitives have been defined: 'len(str, int)'
     604$     returns the first 'int' characters of 'str', and 'rlen(str, int)'
     605$     does the same from the right end of the 'str'.  as usual, on
     606$     success 'str' is shortened by the returned string.
     607$  6. the processing of 'repr' statements has been rewritten.
     608$  7. the processing for 'from',... has been rewritten.
     609$  8. assignments are uniformly handled by 'gasn1'...'gasn4'.  these
     610$     routines replace 'gdefop' and 'gdefop1'.
     611$  9. multi-variate maps now are represented as [[d1, d2, ..., dn] r].
     612$     the necessary changes to 'gof' and 'gofa' have been made.
     613$ 10. the code generated for domain iterators had to be changed to
     614$     reflect the semantic change outlined under (9.).
     615$ 11. the 'notexist' quantifier has been added.
     616$ 12. a binary form of the compound operator has been added.  its syntax
     617$     is 'e1 op/ e2', its semantic e1 op e2(1) op e2(2) op ... op e2(n).
     618
     619
     620$ 07/25/79     79206     s. freudenberger
     621$
     622$ inclusion deck 'binaryio' has been renamed 'binio'.
     623
     624
     625$ 07/20/79     79201     s. freudenberger
     626$
     627$ 1. 'q1tab' is initialized by a data-statement, and not via executable
     628$    code at the beginning of execution.
     629$ 2. error messages on the dec-10 are written to the device 'tty:',
     630$    rather then the file 'tty'.
     631$ 3. error messages on the dec-10 are preceded by '?', the standard
     632$    error marker for that system.  also, warning messages are preceded
     633$    by ':'.
     634$ 4. the default file titles for the binder- and setl-q1 files have been
     635$    changed to '0' (zero), the little default for a *sink*.  after the
     636$    files have been opened, the titles are reset to the null string.
     637$    n.b. this saves us to test whether files have been supplied, since
     638$    we can read from and write to the *sink* indefinitely.
     639$ 5. 'semini' prints a line 'start...' on the terminal.
     640$ 6. 'gcnst1' has been modified to handle 'om' as a constant.
     641$ 7. error messages in 'gcnst1' and 'gvar' have been changed to aid
     642$    novice users in their aim to understand their meaning.
     643$ 8. the result of a set former must be a temporary.  this had been
     644$    changed incorrectly for v2.0(79138).
     645$ 9. 'genst' incorrectly called 'gttup1' when it pushed negative-2 onto
     646$    'astac', a ps-sized array.  this has been corrected by special
     647$    casing for n=0, pushing 'f_gen' and 'sym_zero', and calling
     648$    'gttup2' directly.
     649$ 10. 'val'-entries and strings are now correctly written to the setl-
     650$     q1 file.
     651
     652
     653$ 05/18/79     79138     s. freudenberger and d. shields
     654$
     655$ 1. more shared code has been moved into 'cmnpl'.
     656$ 2. code has been added to write the q1 file in setl binary
     657$    format.  this involves a new control card parameter,
     658$    sq1, to specify the file name of the setl q1 file, as
     659$    well as code to write out the setl format q1 file.
     660$ 3. the code sequence for iterative set formers has been
     661$    modified to meet an optimizer constraint.  the new code
     662$    sequence assigns the result of the incremented element
     663$    counter to a temporary, and then assigns the temporary
     664$    back to the counter.
     665$ 4. the code sequence for arithmetic iterators has been
     666$    modified along simillar lines.  here the result of
     667$    adding the increment to the index variable is first
     668$    assigned to a (new) temporary, then assigned back to the
     669$    index variable.
     670$ 5. overall, code has been cleaned up.
     671
     672
     673$ 04/27/79     79117     s. freudenberger
     674$
     675$ 1. 'ghead6' has been modified so that in a short compilation
     676$    (i.e. a compilation with no directory) a rights list of
     677$    zeros is given to the member name.  this way the optimizer
     678$    can assume that every member name has a rights list.
     679$ 2. to further reduce the amount of output produced by this
     680$    phase, no message is printed anymore at the beginning of each
     681$    unit.  error messages and dump headings have been modified to
     682$    account for this change.
     683$ 3. after the symbols '_' and '/_' can not be operators anymore
     684$    (cf. character set change, version 79102), it seemed logical
     685$    to delete them from the symbol table as well.  this has been
     686$    done, and also triggered changes 4 and 5.
     687$ 4. since the data structures for the q1 symbol table and the form
     688$    table are shared among several phases of the compiler, they
     689$    have been placed into a special library, 'cmnpl'.  they are
     690$    now included into the compilation as an inclusion library.
     691$    n.b. there is more code that should be placed into this
     692$         common library.
     693$ 5. the names for system variables are now preceded by 's$', and
     694$    the names of globals by 'g$'.
     695$ 6. a start has been made to eliminate the phase heading.  the
     696$    file information is now printed two files per line.
     697
     698
     699$ 04/12/79     79102     s. freudenberger and d. shields
     700$
     701$ 1. an option has been added to echo all error messages to the terminal
     702$    file specified by the -term- control card parameter.
     703$ 2. the layout of the q1 statistics has been condensed.
     704
     705
     706$ 04/10/79     79100     s. freudenberger
     707$
     708$ 1. some form table fields for the 6600 have been redefined to
     709$    avoid the -ft_pos- field to cross a word boundery.
     710$ 2. the 'q1_na' instruction is emitted with the correct argument.
     711$ 3. the symbol table dimension has been increased to 1500.
     712
     713
     714$ 04/03/79     79093     s. freudenberger and d. shields
     715$
     716$ 1. as a first step to remove prefix stropping, the pre control card
     717$    parameter has been deleted, and the pre_flag initialized to
     718$    reserved word stropping.
     719$ 2. the blockof-field of the first q1 instruction has been made to
     720$    point back to the blocktab entry (as the documentation promisses).
     721$ 3. the form predicates have been implemented in a different way, so
     722$    that machines with a wordsize less than 35 bits will get the
     723$    correct results.  (the new implementation also should be more
     724$    efficient)
     725
     726
     727$ 03/27/79     79086     s. freudenberger
     728$
     729$ 1. the code sequence generated for -from- has be corrected.
     730$ 2. an erroneous field definition for s10 has been corrected.
     731$ 3. the predicates on forms have been reviewed and corrected.
     732$ 4. the size of the names table has been increased to 1500.
     733
     734
     735$ 03/15/79     79074     s. freudenberger
     736$
     737$ 1. the order in which the q1 tables are written onto the
     738$    q1 file has been changed to conform with the sequence
     739$    in which the optimizer reads them in.
     740$ 2. the routine -move- has been renamed -movblk-.
     741$ 3. the following semantic pass debugging options have been
     742$    renamed:
     743$         tre0 ---> stre0
     744$         tre1 ---> stre1
     745$         trs0 ---> strs0
     746$         trs1 ---> strs1
     747$ 4. the code emitted for 'f(x) from g(y)' has been corrected.
     748$ 5. the size of the array -opname- in routine -dblock- has been
     749$    increased so that there is enough space to store the longest
     750$    op name.
     751
     752
     753$ 03/05/79     79065     s. freudenberger
     754$
     755$ 1. the following changes have been made to the debug statement
     756$    options:
     757$
     758$    1.1 three new options have been introduced to allow local dumps
     759$        during code generation (see comment in setl.cod for more
     760$        detail)
     761$    1.2 two semantic pass options have been renamed:
     762$            q1dump ----> sq1cd
     763$            symdump ---> sq1sd
     764$    1.3 a typo in the spelling of sym_rtrs0 has been corrected.
     765$ 2. the statement numbering has been cleaned up.  hopefully error
     766$    messages will print now the statement number corresponding to
     767$    the source listing...
     768
     769
     770$ 02/12/79     79043     a. grand and s. freudenberger
     771$
     772$ 1. the code for evaluating the expression in
     773$       <*bin> '/' '['  ':'  ']'
     774$    has been moved inside the iterator block.
     775
     776
     777$ 12/27/78     78361     a. grand and d. shields
     778$
     779$ this mod includes machine dependent code for the ibm-370, dec-10,
     780$ and vax.
     781
     782
     783$ 12/08/78     78342     a. grand
     784$
     785$ 1. there is a control card option 'diter' which specifies that
     786$    (! x _ s) can be done using x and s directly. we only make this
     787$    optimization when x and s are know to have compatible types.
     788$    the same option allows us to do use 'i' directly in (! i := 1...n).
     789$    here we only make the optimization if i is general or an integer.
     790$ 2. the assignment f(x+1, y) := z was not processed correctly. we
     791$    now allocate an internal variable 't' and emit
     792$    t := x+1; f(t, y) := z;
     793$ 3. the size of argtab has been increased to 4000.
     794
     795
     796$ 11-15-78     78319     a. grand and s. freudenberger
     797$
     798$ 1. it adds the deck 'mods'.
     799$ 2. it fixes various bugs in the treatment of short iterators.
     800$ 3. it sets the is_back flag of the temporaries yielded by quantifiers.
     801$ 4. it redoes the treatment of statement numbers in the q1 code.
     802
     803
       1 .=member start
suna  15 .=include cndasm
suna  16
suna  17 .+r32 prog stlsem;
suna  18 .+r36 prog stlsem;
       7 .+s66 subr start;
       8
       9$ in this section we define all the data structures of the semantic
      10$ pass. we begin with a few meta macros and utilities.
      11
      12      +* prog_level =   $ program level (julian date of last fix)
bnda  13          'sem(85007) '
      14          **
      15
      16
      18 .=include sysmac
      19
      20      macdrop(deflab)         $ since we have a routine 'deflab'
      21
      22
      23      +*  maxsi  =  $ maximum value for short int
      24 .+s66    3b'377777'
      25 .+r32    4b'3fffff'
      26 .+s10    3b'777777'
      27 .+s20    3b'777777'
      28          **
      29
      30
      31$ the polish string
      32$ -----------------
      33
      34$ the output of the parser is a reversed polish string. the polish
      35$ string is represented as an array of nodes, each of which may
      36$ occupy one or more words. the first word of each node has a
      37$ standard format and contains the following fields:
      38
      39$ pol_typ:      type code pol_xxx
      40$ pol_val:      value of entry
      41
      42$ there are three types of nodes
      43
      44$ a. names
      45
      46$    these nodes indicate names appearing in the source program.
      47$    they have:
      48
      49$    pol_typ:     pol_name
      50$    pol_val:     length of name in words
      51
      52$    the actual name is contained in successive words,
      53$    stored in the format used by the 'names' array.
      54
      55$ b. counters
      56
      57$    counters are integers which indicate the number of clauses
      58$    found by each  operation of the parser. they have:
      59
      60$    pol_typ:     pol_count
      61$    pol_val:     integer indicating count
      62
      63$ c. markers
      64
      65$    markers are nodes indicating points where semantic routines
      66$    are to be invoked. they have:
      67
      68$    pol_typ:     pol_mark
      69$    pol_val:     code p_xxx
      70
      71$ we do not keep the entire polish string in core at once, but rather
      72$ read in nodes as we need them.
      73
      74$ the polish string is actually read in from two files called the
      75$ main and auxiliary files. the auxiliary file contains a description
      76$ of each procedure and its parameters. the two files are read in
      77$ alternately so that we can process forward references to procedures.
      78
      79$ the variable pol_file gives the number of the polish string file
      80$ currently being read. it is reset by the routines gsw1 and gsw2.
      81
      82$ the fields of each node are:
      83
      84
      85      +*  polsz  =  16  **  $ size of node header
      86
      87      +*  pol_typ_       =  .f. 01, 02, **
      88      +*  pol_val_       =  .f. 03, 14, **
      89
      90 .+r32    +*  polsz  =  32  **   $ upsized node header
      91
      92 .+r32    +*  pol_typ_       =   .f. 01, 02, **
      93 .+r32    +*  pol_val_       =   .f. 03, 30, **
      94
      95
      96      +*  getp(tp, vl) =   $ read node from polish
      97          size zzza(polsz);
      98
      99          read pol_file, zzza;
     100          tp = pol_typ_ zzza;
     101          vl = pol_val_ zzza;
     102          **
     103
     104$ polish string types
     105
     106 .=zzyorg z
     107
     108      defc0(pol_name)         $ name
     109      defc0(pol_count)        $ counter
     110      defc0(pol_mark)         $ marker
     111      defc0(pol_end)          $ end-of-file node
     112
     113      +*  pol_min  =  pol_name   ** $ minimum type
     114      +*  pol_max  =  pol_end    ** $ maximum type
     115
     116
     117$ the macros defining the polish string markers are generated
     118$ by 'syn' when it compiles the grammar, and are included here.
     119
     120      +*  synimpmap(a, b)  =  macdef(a = b)  **
     121
     122 .=include synmac
suna  20 .=include synimp             $ include macros
     124
     125
     126
     127
     128$ q1 data structures
     129$ ------------------
     130
     131$ in the next section we describe the various q1 data structures.
     132$ the q1 tables are written out in pages at the end of each unit.
     133$ only those pages necessary to process the current unit are kept
     134$ in core at any given time.
     135
     136$ a page of q1 consists of:
     137
     138$ 1. the unit type unit_xxx
     139$ 2. a string of toklen_lim characters giving the unit name
     140$ 3. a pointer to the symtab entry for the unit
     141$ 4. the number of procedures in current member
     142$ 5. the number of the first statement for the unit.
     143$ 6. slices of the q1 tables.
     144
     145$ note that we never write out an entire q1 table. instead we
     146$ write out an array slice which contains all the new entries
     147$ for the current unit.
     148
     149$ each array slice is identified by two pointers:
     150
     151$ xxx_org:     pointer to zero-th entry
     152$ xxxp:        pointer to last entry
     153
     154$ we read array entries from xxx(xxx_org+1) to xxx(xxxp).
     155
     156$ the q1 file ends with a special page with type unit_end.
     157$ this page does not contain items 2-6 above.
     158
     159
     160 .=include q1symtab
     161
     162
     163$ symtab is arranged as a hash table, with the link field used
     164$ to resolve all collisions. a separate array called 'heads'
     165$ holds the head of each clash list.
     166
     167
     168      +*  heads_lim  =        $ number of hash headers
     169 .+s10    211
     170 .+s20    211
     171 .+r32    1021
     172 .+s66    211
     173          **
     174
     175
     176      size heads(ps);  $ array of hash headers
     177      dims heads(heads_lim);
     178      data heads = 0(heads_lim);
     179
     180
     181 .=include formtab
     182
     183
     184      +*  fheads_lim  =       $ number of hash headers
     185 .+s10    101
     186 .+s20    101
     187 .+r32    509
     188 .+s66    101
     189          **
     190
     191
     192      size fheads(ps);        $ form table hash headers
     193      dims fheads(fheads_lim);
     194      data fheads = 0(fheads_lim);
     195
     196
     197 .=include q1code
     198 .=include binio
smfc  11 .=include lipkg              $ long integer arithmetic package
     199
     200
     201$ internal data structures
     202$ ------------------------
     203
smfb  50$ the semantic pass uses three auxiliary stacks to generate code.
     205$ these are:
     206
     207
     208$ astack
     209$ ------
     210
     211$ this is an argument stack used for communication between the various
     212$ semantic routines. its entries are symbol table pointers, integers
     213$ etc. the variable 'asp' points to the top entry of astack.
     214
     215      +*  astack_lim = $ length of astack
     216 .+s10    1000
     217 .+s20    1000
     218 .+r32    10000
     219 .+s66    1000
     220          **
     221
     222      size astack(ps);
     223      dims astack(astack_lim);
     224
     225      size asp(ps);
     226      data asp = 0;
     227
     228$ the following macros are used to manipulate astack:
     229
     230      +*  get_stack(n)  =  $ get stack space
     231          asp = asp + (n);
     232          if (asp > astack_lim) call overfl('astack');
     233          **
     234
     235
     236      +*  free_stack(n)  =  $ free stack space
     237 .+tr.
     238          if (n) > asp then  $ underflow
     239              put, skip, 'astack underflow', skip;
     240              asp = n;
     241          end if;
     242 ..tr
     243          asp = asp - (n);
     244          **
     245
     246
     247      +*  stack_trace(str, n)  =  $ trace astack
     248          if (trs_flag)
     249              put, x(2), str, x(2):
     250                   astack(asp-(n)+1) to astack(asp), il, skip;
     251          **
     252
     253
     254      +*  push1(a)  =   $ push a
     255          get_stack(1);
     256          astack(asp) = a;
     257 .+tr     stack_trace('push', 1);
     258          **
     259
     260      +*  push2(a, b)  =  $ push a; push b;
     261          get_stack(2);
     262          astack(asp)   = b;
     263          astack(asp-1) = a;
     264 .+tr     stack_trace('push', 2);
     265          **
     266
     267
     268      +*  push3(a, b, c)  =
     269          get_stack(3);
     270          astack(asp)   = c;
     271          astack(asp-1) = b;
     272          astack(asp-2) = a;
     273 .+tr     stack_trace('push', 3);
     274          **
     275
     276
     277      +*  push4(a, b, c, d)  =
     278          get_stack(4);
     279          astack(asp)   = d;
     280          astack(asp-1) = c;
     281          astack(asp-2) = b;
     282          astack(asp-3) = a;
     283 .+tr     stack_trace('push', 4);
     284          **
     285
     286
     287      +*  pop1(a)  =    $ pop a;
     288 .+tr     stack_trace('pop', 1);
     289          a = astack(asp);
     290          free_stack(1);
     291          **
     292
     293
     294      +*  pop2(a, b)  =  $ pop a;  pop b;
     295 .+tr     stack_trace('pop', 2);
     296          a = astack(asp);
     297          b = astack(asp-1);
     298          free_stack(2);
     299          **
     300
     301
     302      +*  pop3(a, b, c)  =
     303 .+tr     stack_trace('pop', 3);
     304          a = astack(asp);
     305          b = astack(asp-1);
     306          c = astack(asp-2);
     307          free_stack(3);
     308          **
     309
     310
     311      +*  pop4(a, b, c, d)  =
     312 .+tr     stack_trace('pop', 4);
     313          a = astack(asp);
     314          b = astack(asp-1);
     315          c = astack(asp-2);
     316          d = astack(asp-3);
     317          free_stack(4);
     318          **
smfb  51
smfb  52
smfb  53
smfb  54
smfb  55$ bstack
smfb  56$ ------
smfb  57
smfb  58$ bstack is used to generate code for boolean expressions.
smfb  59
smfb  60      +* bstack_sz  =
smfb  61 .+s10    72
smfb  62 .+s20    72
smfb  63 .+r32    64
smfb  64 .+s66    60
smfb  65          **
smfb  66
smfb  67      +*  bstack_lim  =  100  **
smfb  68
smfb  69      size bstack(bstack_sz);
smfb  70      dims bstack(bstack_lim);
smfb  71
smfb  72      size bsp(ps);
smfb  73      data bsp = 0;
smfb  74
smfb  75 .+s10.
smfb  76      +*  bs_temp(p)      =  .f.  1, 18, bstack(p)        **
smfb  77      +*  bs_true(p)      =  .f. 19, 18, bstack(p)        **
smfb  78      +*  bs_false(p)     =  .f. 37, 18, bstack(p)        **
smfb  79 ..s10
smfb  80
smfb  81 .+s20.
smfb  82      +*  bs_temp(p)      =  .f.  1, 18, bstack(p)        **
smfb  83      +*  bs_true(p)      =  .f. 19, 18, bstack(p)        **
smfb  84      +*  bs_false(p)     =  .f. 37, 18, bstack(p)        **
smfb  85 ..s20
smfb  86
smfb  87 .+r32.
smfb  88      +*  bs_temp(p)      =  .f.  1, 16, bstack(p)        **
smfb  89      +*  bs_true(p)      =  .f. 17, 16, bstack(p)        **
smfb  90      +*  bs_false(p)     =  .f. 33, 16, bstack(p)        **
smfb  91 ..r32
smfb  92
smfb  93 .+s66.
smfb  94      +*  bs_temp(p)      =  .f.  1, 15, bstack(p)        **
smfb  95      +*  bs_true(p)      =  .f. 16, 15, bstack(p)        **
smfb  96      +*  bs_false(p)     =  .f. 31, 15, bstack(p)        **
smfb  97 ..s66
     319
     320
     321
     322
     323$ cstack
     324$ ------
     325
     326$ cstack is used to process control statements, such as 'if',
     327$ 'case', and 'while'.
     328
     329$ there are four types of cstack entries:
     330
     331$ cs_if:      if statements and conditional expressions
     332$ cs_case:    case statements and expressions
     333$ cs_iter:    first loop in compound iterator
     334$ cs_citer:   inner loop in compound iterator
     335
     336$ cstack has the following fields:
     337
     338$ cs_type:      code cs_xxx
     339
     340
     341$ fields for loops:
     342
     343$ cs_internal:  flags internal iterator
     344$ cs_bvar:      name of bound variable for short iterators
     345$ cs_ldoing:    name of label for doing block
     346$ cs_lstep:     name of label for step block
     347$ cs_lterm:     name of label for term block
     348$ cs_lquit:     name of label for quit target
     349$ cs_init:      code pointer to end of init block
     350$ cs_doing:     code pointer to end of doing block
     351$ cs_while:     code pointer to end of while block
     352$ cs_where:     code pointer to end of where block
     353$ cs_body:      code pointer to end of body
     354$ cs_step:      code pointer to end of step block
     355$ cs_until:     code pointer to end of until block
     356$ cs_term:      code pointer to end of term block
     357
     358$ fields for 'if' statements and expressions
     359
     360$ cs_else:      name of else label
     361$ cs_end:       name of end label
     362$ cs_temp:      name of result temporary for if expressions
     363
     364$ fields for expression blocks
     365
     366$ cs_end:       name of label for end of block
     367$ cs_temp:      name of temporary yielded by block
     368
     369$ fields for case statements and expressions
     370
     371$ cs_num:       counter for number of case tags
     372$ cs_jump:      code pointer to branch instruction
     373$ cs_tag:       name of label for current tag
     374$ cs_else:      name of label for else clause
     375$ cs_end:       name of label for end
     376$ cs_temp:      name of result temporary for case expression
     377
     378$ the variable 'csp' points to the top cstack entry.
     379
     380$ the macros for cstack are:
     381
     382      +* cstack_sz  =
     383 .+s10    216
     384 .+s20    216
     385 .+r32    224
     386 .+s66    240
     387          **
     388
     389
smfb  98      +*  cstack_lim  =  100  **
     391
     392      size cstack(cstack_sz);
     393      dims cstack(cstack_lim);
     394
     395      size csp(ps);
     396      data csp = 0;
     397
     398
     399 .+s10.    $ fields for dec-10
     400      +*  cs_type(p)        =  .f. 001, 03, cstack(p)  **
     401      +*  cs_internal(p)    =  .f. 004, 01, cstack(p)  **
     402      +*  cs_bvar(p)        =  .f. 013, 12, cstack(p)  **
     403      +*  cs_ldoing(p)      =  .f. 025, 12, cstack(p)  **
     404      +*  cs_lstep(p)       =  .f. 037, 12, cstack(p)  **
     405      +*  cs_lterm(p)       =  .f. 049, 12, cstack(p)  **
     406      +*  cs_lquit(p)       =  .f. 061, 12, cstack(p)  **
     407      +*  cs_init(p)        =  .f. 073, 18, cstack(p)  **
     408      +*  cs_doing(p)       =  .f. 091, 18, cstack(p)  **
     409      +*  cs_while(p)       =  .f. 109, 18, cstack(p)  **
     410      +*  cs_where(p)       =  .f. 127, 18, cstack(p)  **
     411      +*  cs_body(p)        =  .f. 145, 18, cstack(p)  **
     412      +*  cs_step(p)        =  .f. 163, 18, cstack(p)  **
     413      +*  cs_until(p)       =  .f. 181, 18, cstack(p)  **
     414      +*  cs_term(p)        =  .f. 199, 18, cstack(p)  **
     415 ..s10
     416
     417 .+s20.    $ fields for dec-10
     418      +*  cs_type(p)        =  .f. 001, 03, cstack(p)  **
     419      +*  cs_internal(p)    =  .f. 004, 01, cstack(p)  **
     420      +*  cs_bvar(p)        =  .f. 013, 12, cstack(p)  **
     421      +*  cs_ldoing(p)      =  .f. 025, 12, cstack(p)  **
     422      +*  cs_lstep(p)       =  .f. 037, 12, cstack(p)  **
     423      +*  cs_lterm(p)       =  .f. 049, 12, cstack(p)  **
     424      +*  cs_lquit(p)       =  .f. 061, 12, cstack(p)  **
     425      +*  cs_init(p)        =  .f. 073, 18, cstack(p)  **
     426      +*  cs_doing(p)       =  .f. 091, 18, cstack(p)  **
     427      +*  cs_while(p)       =  .f. 109, 18, cstack(p)  **
     428      +*  cs_where(p)       =  .f. 127, 18, cstack(p)  **
     429      +*  cs_body(p)        =  .f. 145, 18, cstack(p)  **
     430      +*  cs_step(p)        =  .f. 163, 18, cstack(p)  **
     431      +*  cs_until(p)       =  .f. 181, 18, cstack(p)  **
     432      +*  cs_term(p)        =  .f. 199, 18, cstack(p)  **
     433 ..s20
     434
     435
     436
     437 .+r32.    $ fields for regular 32-bit implementatinon
     438      +*  cs_type(p)        =  .f. 001, 08, cstack(p)  **
     439      +*  cs_internal(p)    =  .f. 009, 08, cstack(p)  **
     440      +*  cs_bvar(p)        =  .f. 017, 16, cstack(p)  **
     441      +*  cs_ldoing(p)      =  .f. 033, 16, cstack(p)  **
     442      +*  cs_lstep(p)       =  .f. 049, 16, cstack(p)  **
     443      +*  cs_lterm(p)       =  .f. 065, 16, cstack(p)  **
     444      +*  cs_lquit(p)       =  .f. 081, 16, cstack(p)  **
     445      +*  cs_init(p)        =  .f. 097, 16, cstack(p)  **
     446      +*  cs_doing(p)       =  .f. 113, 16, cstack(p)  **
     447      +*  cs_while(p)       =  .f. 129, 16, cstack(p)  **
     448      +*  cs_where(p)       =  .f. 145, 16, cstack(p)  **
     449      +*  cs_body(p)        =  .f. 161, 16, cstack(p)  **
     450      +*  cs_step(p)        =  .f. 177, 16, cstack(p)  **
     451      +*  cs_until(p)       =  .f. 193, 16, cstack(p)  **
     452      +*  cs_term(p)        =  .f. 209, 16, cstack(p)  **
     453 ..r32
     454
     455
     456 .+s66.   $ fields for cdc 6600
     457      +*  cs_type(p)        =  .f. 055, 03, cstack(p)  **
     458      +*  cs_internal(p)    =  .f. 058, 01, cstack(p)  **
     459      +*  cs_bvar(p)        =  .f. 001, 17, cstack(p)  **
     460      +*  cs_ldoing(p)      =  .f. 019, 17, cstack(p)  **
     461      +*  cs_lstep(p)       =  .f. 037, 17, cstack(p)  **
     462      +*  cs_lterm(p)       =  .f. 061, 17, cstack(p)  **
     463      +*  cs_lquit(p)       =  .f. 079, 17, cstack(p)  **
     464      +*  cs_init(p)        =  .f. 121, 15, cstack(p)  **
     465      +*  cs_doing(p)       =  .f. 136, 15, cstack(p)  **
     466      +*  cs_while(p)       =  .f. 151, 15, cstack(p)  **
     467      +*  cs_where(p)       =  .f. 166, 15, cstack(p)  **
     468      +*  cs_body(p)        =  .f. 181, 15, cstack(p)  **
     469      +*  cs_step(p)        =  .f. 196, 15, cstack(p)  **
     470      +*  cs_until(p)       =  .f. 211, 15, cstack(p)  **
     471      +*  cs_term(p)        =  .f. 226, 15, cstack(p)  **
     472 ..s66
     473
     474
     475      +*  cs_else(p)        =  cs_lstep(p)   **
     476      +*  cs_end(p)         =  cs_lterm(p)   **
     477      +*  cs_temp(p)        =  cs_bvar(p)    **
     478      +*  cs_jump(p)        =  cs_init(p)    **
     479      +*  cs_num(p)         =  cs_doing(p)   **
     480      +*  cs_tag(p)         =  cs_ldoing(p)  **
     481
     482$ codes for cs_types
     483
     484 .=zzyorg z
     485
     486      defc(cs_if)             $ if statement or expression
     487      defc(cs_case)           $ case statement of expression
     488      defc(cs_iter)           $ outer loop
     489      defc(cs_citer)          $ inner loop
     490      defc(cs_eblk)           $ expression block
     491
     492      +*  cs_min    =  cs_if    **  $ minimum cs_type
     493      +*  cs_max    =  cs_eblk  **  $ maximum cs_type
     494
     495
     496
     497$ we also use two other internal tables:
     498
     499$ proctab
     500$ -------
     501
     502$ proctab is an array containing the names of all procedures which
     503$ should be defined in this member. it is the union of the members
     504$ exports and procs lists.
     505
     506$ the variable 'proctabp' points to the last entry on proctab.
     507
     508      +*  proctab_lim  = 500  **
     509
     510      size proctab(ps);
     511      dims proctab(proctab_lim);
     512
     513      size proctabp(ps);
     514      data proctab = 0;
     515
     516
     517$ opmap
     518$ -----
     519
     520$ the array 'opmap' maps symbol table pointers into q1 opcodes.
     521
     522      size opmap(ps);
     523      dims opmap(sym_maximum);
     524
     525      data opmap(sym_plus)    =  q1_add:     $ +
     526           opmap(sym_minus)   =  q1_sub:     $ -
     527           opmap(sym_mult)    =  q1_mult:    $ *
     528           opmap(sym_div)     =  q1_div:     $ div
     529           opmap(sym_slash)   =  q1_slash:   $ /
     530           opmap(sym_mod)     =  q1_mod:     $ mod
     531           opmap(sym_exp)     =  q1_exp:     $ **
     532           opmap(sym_lt)      =  q1_lt:      $ <
     533           opmap(sym_gt)      =  q1_lt:      $ '>' permute args, use '<'
     534           opmap(sym_le)      =  q1_ge:      $ <= permute args, use >=
     535           opmap(sym_ge)      =  q1_ge:      $ >=
     536           opmap(sym_eq)      =  q1_eq:      $ =
     537           opmap(sym_ne)      =  q1_ne:      $ /=
     538           opmap(sym_in)      =  q1_in:      $ in
     539           opmap(sym_notin)   =  q1_notin:   $ notin
     540           opmap(sym_incs)    =  q1_incs:    $ incs
     541           opmap(sym_with)    =  q1_with:    $ with
     542           opmap(sym_from)    =  q1_from:    $ from
     543           opmap(sym_fromb)   =  q1_fromb:   $ fromb
     544           opmap(sym_frome)   =  q1_frome:   $ frome
     545           opmap(sym_less)    =  q1_less:    $ less
     546           opmap(sym_lessf)   =  q1_lessf:   $ lessf
     547           opmap(sym_min)     =  q1_min:     $ min
     548           opmap(sym_max)     =  q1_max:     $ max
     549           opmap(sym_subset)  =  q1_incs:    $ subset
     550           opmap(sym_npow)    =  q1_npow:    $ npow
     551           opmap(sym_atan2)   =  q1_atan2:   $ atan2
     552           opmap(sym_not)     =  q1_not:     $ not
     553           opmap(sym_even)    =  q1_even:    $ even
     554           opmap(sym_odd)     =  q1_odd:     $ odd
     555           opmap(sym_isint)   =  q1_isint:   $ is_integer
     556           opmap(sym_isreal)  =  q1_isreal:  $ is_real
     557           opmap(sym_isstr)   =  q1_isstr:   $ is_string
     558           opmap(sym_isbool)  =  q1_isbool:  $ is_boolean
     559           opmap(sym_isatom)  =  q1_isatom:  $ is_atom
     560           opmap(sym_istuple) =  q1_istup:   $ is_tuple
     561           opmap(sym_isset)   =  q1_isset:   $ is_set
     562           opmap(sym_ismap)   =  q1_ismap:   $ is_map
     563           opmap(sym_arb)     =  q1_arb:     $ arb
     564           opmap(sym_dom)     =  q1_dom:     $ domain
     565           opmap(sym_range)   =  q1_range:   $ range
     566           opmap(sym_pow)     =  q1_pow:     $ pow
     567           opmap(sym_nelt)    =  q1_nelt:    $ #
     568           opmap(sym_abs)     =  q1_abs:     $ abs
     569           opmap(sym_char)    =  q1_char:    $ char
     570           opmap(sym_ceil)    =  q1_ceil:    $ ceil
     571           opmap(sym_floor)   =  q1_floor:   $ floor
     572           opmap(sym_fix)     =  q1_fix:     $ fix
     573           opmap(sym_float)   =  q1_float:   $ float
     574           opmap(sym_sin)     =  q1_sin:     $ sin
     575           opmap(sym_cos)     =  q1_cos:     $ cos
     576           opmap(sym_tan)     =  q1_tan:     $ tan
     577           opmap(sym_arcsin)  =  q1_arcsin:  $ asin
     578           opmap(sym_arccos)  =  q1_arccos:  $ acos
     579           opmap(sym_arctan)  =  q1_arctan:  $ atan
     580           opmap(sym_tanh)    =  q1_tanh:    $ tanh
     581           opmap(sym_expf)    =  q1_expf:    $ expf
     582           opmap(sym_log)     =  q1_log:     $ log
     583           opmap(sym_sqrt)    =  q1_sqrt:    $ sqrt
     584           opmap(sym_rand)    =  q1_rand:    $ random
     585           opmap(sym_sign)    =  q1_sign:    $ sign
     586           opmap(sym_type)    =  q1_type:    $ type
     587           opmap(sym_str)     =  q1_str:     $ str
     588           opmap(sym_val)     =  q1_val;     $ val
     589
     590
     591
     592$ q1tab
     593$ -----
     594
     595$ the table 'q1tab' contains various maps defined on q1 opcodes.
     596$ these maps are:
     597
     598$ numargs:        number of arguments
     599$ sinmap:         maps retrieval ops into sinister ops
     600$ defs_temp:      indicates that operation defines a temp
     601
     602$ numargs is zero for operations with variable numbers of operands
     603
     604      +*  numargs(op)     =  .f. 01, 08, q1tab(op)  **
     605      +*  sinmap(op)      =  .f. 09, 08, q1tab(op)  **
     606      +*  defs_temp(op)   =  .f. 17, 01, q1tab(op)  **
     607
     608      size q1tab(24);
     609      dims q1tab(q1_maximum);
     610      data
     611
     612      +* s(op, a, b, c)  =    $ initialize q1tab entry
     613          q1tab(op) = a + b*4b'000100' + c*4b'010000'
     614          **
     615
     616$ binary operators:
     617
     618      s(q1_add,       3,          0,       yes):
     619      s(q1_div,       3,          0,       yes):
     620      s(q1_exp,       3,          0,       yes):
     621      s(q1_eq,        3,          0,       yes):
     622      s(q1_ge,        3,          0,       yes):
     623      s(q1_lt,        3,          0,       yes):
smfb  99      s(q1_pos,       3,          0,       yes):
     624      s(q1_in,        3,          0,       yes):
     625      s(q1_incs,      3,          0,       yes):
     626      s(q1_less,      3,          0,       yes):
     627      s(q1_lessf,     3,          0,       yes):
     628      s(q1_max,       3,          0,       yes):
     629      s(q1_min,       3,          0,       yes):
     630      s(q1_mod,       3,          0,       yes):
     631      s(q1_mult,      3,          0,       yes):
     632      s(q1_ne,        3,          0,       yes):
     633      s(q1_notin,     3,          0,       yes):
     634      s(q1_npow,      3,          0,       yes):
     635      s(q1_atan2,     3,          0,       yes):
     636      s(q1_slash,     3,          0,       yes):
     637      s(q1_sub,       3,          0,       yes):
     638      s(q1_with,      3,          0,       yes):
     639
     640$ unary operators:
     641
     642      s(q1_abs,       2,          0,       yes):
     643      s(q1_char,      2,          0,       yes):
     644      s(q1_ceil,      2,          0,       yes):
     645      s(q1_floor,     2,          0,       yes):
     646      s(q1_isint,     2,          0,       yes):
     647      s(q1_isreal,    2,          0,       yes):
     648      s(q1_isstr,     2,          0,       yes):
     649      s(q1_isbool,    2,          0,       yes):
     650      s(q1_isatom,    2,          0,       yes):
     651      s(q1_istup,     2,          0,       yes):
     652      s(q1_isset,     2,          0,       yes):
     653      s(q1_ismap,     2,          0,       yes):
     654      s(q1_arb,       2,          0,       yes):
     655      s(q1_val,       2,          0,       yes):
     656      s(q1_dom,       2,          0,       yes):
     657      s(q1_fix,       2,          0,       yes):
     658      s(q1_float,     2,          0,       yes):
     659      s(q1_nelt,      2,          0,       yes):
     660      s(q1_not,       2,          0,       yes):
     661      s(q1_pow,       2,          0,       yes):
     662      s(q1_sin,       2,          0,       yes):
     663      s(q1_cos,       2,          0,       yes):
     664      s(q1_tan,       2,          0,       yes):
     665      s(q1_arcsin,    2,          0,       yes):
     666      s(q1_arccos,    2,          0,       yes):
     667      s(q1_arctan,    2,          0,       yes):
     668      s(q1_tanh,      2,          0,       yes):
     669      s(q1_expf,      2,          0,       yes):
     670      s(q1_log,       2,          0,       yes):
     671      s(q1_sqrt,      2,          0,       yes):
     672      s(q1_rand,      2,          0,       yes):
     673      s(q1_range,     2,          0,       yes):
     674      s(q1_type,      2,          0,       yes):
     675      s(q1_umin,      2,          0,       yes):
     676      s(q1_even,      2,          0,       yes):
     677      s(q1_odd,       2,          0,       yes):
     678      s(q1_str,       2,          0,       yes):
     679      s(q1_sign,      2,          0,       yes):
     680
     681$ miscellaneous:
     682
     683      s(q1_end,       3,    q1_send,       yes):
     684      s(q1_subst,     4,  q1_ssubst,       yes):
     685      s(q1_newat,     1,          0,       yes):
     686      s(q1_time,      1,          0,       yes):
     687      s(q1_date,      1,          0,       yes):
     688      s(q1_na,        1,          0,       yes):
     689      s(q1_set,       0,          0,       yes):
     690      s(q1_set1,      3,          0,       no ):
     691      s(q1_tup,       0,          0,       yes):
     692      s(q1_tup1,      3,          0,       no ):
     693      s(q1_from,      2,          0,       no ):
     694      s(q1_fromb,     2,          0,       no ):
     695      s(q1_frome,     2,          0,       no ):
     696
     697$ iterators:
     698
     699      s(q1_next,      3,          0,       no ):
     700      s(q1_nextd,     3,          0,       no ):
     701      s(q1_inext,     3,          0,       no ):
     702      s(q1_inextd,    3,          0,       no ):
     703
     704$ mappings:
     705
     706      s(q1_of,        3,     q1_sof,       yes):
     707      s(q1_ofa,       3,    q1_sofa,       yes):
     708
     709      s(q1_sof,       3,          0,       no ):
     710      s(q1_sofa,      3,          0,       no ):
     711      s(q1_send,      3,          0,       no ):
     712      s(q1_ssubst,    4,          0,       no ):
     713
     714$ assignments:
     715
     716      s(q1_asn,       2,          0,       no ):
     717
     718$ argument passage:
     719
     720      s(q1_argin,     3,          0,       no ):
     721      s(q1_argout,    3,          0,       yes):
     722
     723      s(q1_push,      2,          0,       no ):
     724      s(q1_free,      3,          0,       no ):
     725
     726$ control statements:
     727
     728      s(q1_call,      2,          0,       no ):
     729      s(q1_goto,      1,          0,       no ):
     730
     731      s(q1_if,        2,          0,       no ):
     732      s(q1_ifnot,     2,          0,       no ):
smfb 100      s(q1_bif,       2,          0,       no ):
smfb 101      s(q1_bifnot,    2,          0,       no ):
smfb 102      s(q1_ifasrt,    1,          0,       no ):
bnda  14      s(q1_case,      2,          0,       no ):
     734      s(q1_stop,      0,          0,       no ):
     735
     736      s(q1_entry,     1,          0,       no ):
     737      s(q1_exit,      1,          0,       no ):
     738
     739      s(q1_ok,        0,          0,       no ):
     740      s(q1_lev,       1,          0,       yes):
     741      s(q1_fail,      0,          0,       no ):
     742      s(q1_succeed,   0,          0,       no ):
     743
     744      s(q1_asrt,      1,          0,       no ):
     745      s(q1_stmt,      0,          0,       no ):
     746      s(q1_label,     1,          0,       no ):
     747      s(q1_tag,       1,          0,       no ):
     748      s(q1_debug,     1,          0,       no ):
     749      s(q1_trace,     1,          0,       no ):
     750      s(q1_notrace,   1,          0,       no ):
     751      s(q1_error,     0,          0,       no ):
     752      s(q1_noop,      0,          0,       no );
     753
     754      macdrop(s)
     755
     756
     757$ the matrix 'prefix_map' is used to handle type descriptors
     758$ such as 'remote set(int)' which involve a prefix and a type.
     759$ it maps the prefix and the initial ft_type into a new ft_type.
     760
     761      +*  prefix_map(prefix, type) =
     762          .f. 1 + 8 * (prefix-sym_local), 8, a_prefix(type+1)
     763          **
     764
     765      size a_prefix(40);
     766      dims a_prefix(f_max+1);
     767      data a_prefix = 0(f_max+1);
     768
     769
     770$ the function 'mode_map' maps mode keywords (such as 'general') to
     771$ the corresponding forms (such as 'f_gen').
     772
     773      +*  mode_map(mode)  =  a_mode(mode - sym_mgen + 1)  **
     774
     775      size a_mode(ps);
     776      dims a_mode(sym_mode_max - sym_mode_min + 1);
     777
     778      data a_mode(sym_mgen)    =  f_gen:
     779           a_mode(sym_mint)    =  f_int:
     780           a_mode(sym_mreal)   =  f_real:
     781           a_mode(sym_mstring) =  f_string:
     782           a_mode(sym_mbool)   =  f_atom:
     783           a_mode(sym_matom)   =  f_atom:
     784           a_mode(sym_merror)  =  f_error:
     785           a_mode(sym_melmt)   =  0:
     786           a_mode(sym_mtuple)  =  f_tuple:
     787           a_mode(sym_mset)    =  f_uset:
     788           a_mode(sym_mmap)    =  f_umap:
     789           a_mode(sym_msmap)   =  0:
     790           a_mode(sym_mmmap)   =  0;
     791
     792
     793$ the functions 'tuple_type' and 'map_type' map element forms
     794$ to the corresponding tuple- and map-forms.
     795
     796      +*  tuple_type(fm)  =  .f. 01, 08, a_type_tab(ft_type(fm)+1)  **
     797      +*  map_type(fm)    =  .f. 09, 08, a_type_tab(ft_type(fm)+1)  **
     798
     799      size a_type_tab(32);
     800      dims a_type_tab(f_max+1);
     801      data
     802
     803      +*  s(fm, tuple, map)  =
     804          a_type_tab(fm+1)  =     map*4b'000100'
     805                              + tuple*4b'000001'
     806          **
     807
     808      s(f_gen,       f_tuple,   f_umap   ):
     809      s(f_sint,      f_tuple,   f_umap   ):
     810      s(f_sstring,   f_tuple,   f_umap   ):
     811      s(f_atom,      f_tuple,   f_umap   ):
     812      s(f_latom,     f_tuple,   f_umap   ):
     813      s(f_elmt,      f_tuple,   f_umap   ):
     814      s(f_uint,      f_ituple,  f_uimap  ):
     815      s(f_ureal,     f_rtuple,  f_urmap  ):
     816      s(f_int,       f_tuple,   f_umap   ):
     817      s(f_string,    f_tuple,   f_umap   ):
     818      s(f_real,      f_tuple,   f_umap   ):
     819      s(f_ituple,    f_tuple,   f_umap   ):
     820      s(f_rtuple,    f_tuple,   f_umap   ):
     821      s(f_ptuple,    f_tuple,   f_umap   ):
     822      s(f_tuple,     f_tuple,   f_umap   ):
     823      s(f_mtuple,    f_tuple,   f_umap   ):
     824      s(f_uset,      f_tuple,   f_umap   ):
     825      s(f_lset,      f_tuple,   f_umap   ):
     826      s(f_rset,      f_tuple,   f_umap   ):
     827      s(f_umap,      f_tuple,   f_umap   ):
     828      s(f_lmap,      f_tuple,   f_umap   ):
     829      s(f_rmap,      f_tuple,   f_umap   ):
     830      s(f_lpmap,     f_tuple,   f_umap   ):
     831      s(f_limap,     f_tuple,   f_umap   ):
     832      s(f_lrmap,     f_tuple,   f_umap   ):
     833      s(f_rpmap,     f_tuple,   f_umap   ):
     834      s(f_rimap,     f_tuple,   f_umap   ):
     835      s(f_rrmap,     f_tuple,   f_umap   ):
     836      s(f_base,      f_tuple,   f_umap   ):
     837      s(f_pbase,     f_tuple,   f_umap   ):
     838      s(f_uimap,     f_tuple,   f_umap   ):
     839      s(f_urmap,     f_tuple,   f_umap   ):
     840      s(f_error,     f_tuple,   f_umap   ):
     841      s(f_proc,      f_tuple,   f_umap   ):
     842      s(f_memb,      f_tuple,   f_umap   ):
     843      s(f_lab,       f_tuple,   f_umap   );
     844
     845      macdrop(s);
     846
     847
     848$ miscelaneous global variables
     849$ -----------------------------
     850
     851
     852      size curmemb(ps);       $ name of current member
     853      size curdir(ps);        $ name of current directory
     854      size currout(ps);       $ name of current routine
     855      size curperf(ps);       $ name of current perform block
     856      size curunit(ps);       $ name of current unit
     857
     858      data curmemb  = 0:
     859           curdir   = 0:
     860           currout  = 0:
     861           curperf  = 0:
     862           curunit  = 0;
     863
     864$ each unit has a code unit_xxx associated with it which indicates
     865$ whether it is a module, program, library, or procedure. the
     866$ global unit_type indicates the mode of the current unit, and
     867$ the global 'memb_type' indicates the type of the current member.
     868
     869      size unit_type(ps),
     870           memb_type(ps);
     871
     872 .=zzyorg z     $ unit_xxx codes
     873
     874      defc(unit_sys)          $ unit for system names
     875      defc(unit_lib)          $ library
     876      defc(unit_dir)          $ directory
     877      defc(unit_prog)         $ main program
     878      defc(unit_mod)          $ module
     879      defc(unit_proc)         $ procedure
     880      defc(unit_end)          $ end of compilation
     881
     882      +*  unit_min  =  unit_sys  **
     883      +*  unit_max  =  unit_end  **
     884
     885      data unit_type = unit_sys;
     886
     887      size stop_lab(ps);      $ stop label for current routine
     888      size exit_lab(ps);      $ exit label for current routine
     889
     890      size op_flag(1);        $ true if current procedure is an operator
     891
     892
     893$ we keep three statement counters:
     894
     895$ cstmt_count:   the cummulative statement count
     896$ ustmt_count:   the cstmt_count at the start of the current unit
     897$ estmt_count:   the cstmt_count for the q1_entry instruction in a
     898$                procedure scope.  note that this counter is not set
     899$                in a non-procedure scope.
     900
     901$ the current statement number is equal to cstmt_cout - ustmt_count + 1.
     902      +* stmt_count  =  (cstmt_count - ustmt_count + 1)  **
     903
     904      size cstmt_count(ps);   data cstmt_count = 0;
     905      size ustmt_count(ps);   data ustmt_count = 0;
     906      size estmt_count(ps);   data estmt_count = 0;
     907
     908
     909      size error_count(ps);   $ number of errors
     910      data error_count = 0;
     911
     912
     913$ the following variables are used to process module and program
     914$ headers:
     915
     916      size head_ptr(ps);      $ vptr for corresponding val entry
     917      size head_len(ps);      $ vlen for corresponding val entry
     918      size head_tot(ps);      $ total number of global names in header
     919
     920      size cur_rt(ps);        $ name of rights list being processed
     921
     922$ rt_len maps each rigths name(imports, exports, etc.) into the lenght
     923$ of the corresponding rights list.
     924
     925      +*  rt_len(i)  =  a_rt_len(i - sym_rts_min + 1)  **
     926
     927      size a_rt_len(ps);
     928      dims a_rt_len(sym_rts_max - sym_rts_min + 1);
     929
     930
     931$ 'bvar_flag' is on when we must save the bound variable in
     932$ << x in s st c(x) >>.
     933
     934      size bvar_flag(1);
     935      data bvar_flag = no;
     936
     937$ the flag 'bk_flag' is on when compiling a 'var' statement for
     938$ backtracked variable.
     939
     940      size bk_flag(1);
     941      data bk_flag = no;
     942
     943
     944
     945$ the following variables give the maximum values of various
     946$ table pointers.
     947
     948      size names_max(ps);     $ namesp
     949      size val_max(ps);       $ val
     950      size symtab_max(ps);    $ symtab
     951      size formtab_max(ps);   $ formtab
     952      size mttab_max(ps);     $ mttab
     953      size codetab_max(ps);   $ codetab
     954      size argtab_max(ps);    $ argtab
     955      size blocktab_max(ps);  $ blocktab
     956
     957      data names_max    = 0:
     958           val_max      = 0:
     959           symtab_max   = 0:
     960           formtab_max  = 0:
     961           mttab_max    = 0:
     962           codetab_max  = 0:
     963           argtab_max   = 0:
     964           blocktab_max = 0;
     965
     966
     967
     968
     969$ compilation parameters
     970$ ----------------------
     971
     972$ the following global variables are read in from the control card
     973$ to select various compiler options.
     974
     975      size mpol_title(.sds. filenamlen);  $ main polish file
     976      size xpol_title(.sds. filenamlen);  $ auxiliary polish file
     977      size q1_title(.sds. filenamlen);    $ little q1 file
     978      size sq1_title(.sds. filenamlen);   $ setl q1 file
     979      size bind_title(.sds. filenamlen);  $ binder file
     980      size ibnd_title(.sds. filenamlen);        $ indirect binder file
     981      size term_title(.sds. filenamlen);  $ terminal file
     982
     983      size tre_flag(1);       $ entry trace
     984      size trp_flag(1);       $ polish string trace
     985      size trs_flag(1);       $ astack trace
     986      size ur_flag(1);        $ give warnings for unrepr'ed variables
     987      size uv_flag(1);        $ give warnings for undeclared variables
     988      size et_flag(1);        $ error trace desired
     989      size chk_flag(1);       $ check for valid code fragments
     990      size q1sd_flag(1);      $ q1 symbol table dump requested
     991      size q1cd_flag(1);      $ q1 code dump requested
     992      size sel(ps);           $ semantic error limit
sunb  12      size lcp_flag(1);       $ listing control:  program parameters
sunb  13      size lcs_flag(1);       $ listing control:  program statistics
     993      size opt_flag(1);       $ global optimization flag
smfb 103      size rpr_flag(ps);      $ process repr statements
     995      size sif_flag(1);       $ save intermediate files
     996
     997$ in general, iterations such as 'x in s' must be done using
     998$ shadow variables so that assignments to x and s within the
     999$ loop do not cause problems.
    1000
    1001$ the 'diter' control card option indicates that iteration
    1002$ can be performed directly on x and s. it implies that
    1003$ they are never modified within the loop.
    1004
    1005      size diter_flag(1);
    1006
    1007
    1008$ file identifiers
    1009$ ---- -----------
    1010
    1011 .=zzyorg z
    1012
    1013      defc(inp_file)          $ input
    1014      defc(out_file)          $ output
    1015      defc(mpol_file)         $ main polish file
    1016      defc(xpol_file)         $ auxiliary polish file
    1017      defc(q1_file)           $ q1 output
    1018      defc(sq1_file)          $ setl q1 binary output
    1019      defc(bind_file)         $ binder input
    1020      defc(ibnd_file)         $ indirect binder inputs
    1021
    1022      size pol_file(ps);      $ current polish file
    1023      data pol_file = mpol_file;
    1024
    1025
    1026$ utility functions
    1027$ -----------------
    1028
    1029$ the following utility functions are used often enough to be sized
    1030$ globaly:
    1031
    1032      size hash(ps),          $ hashes array into symtab
    1033           hashst(ps),        $ hashes string into symtab
    1034           hashf1(ps),        $ hashes simple form into formtab
    1035           hashf2(ps),        $ hashes form with mttab entry into formta
    1036           getsym(ps),        $ gets new symtab entry
    1037           gettmp(ps),        $ gets new temporary
    1038           getvar(ps),        $ gets new variable
    1039           getglb(ps),        $ gets new global
    1040           getlab(ps),        $ gets new label
    1041           getint(ps),        $ gets new integer
    1042           copy(ps),          $ copies the code for an expression
    1043           symsds(sds_sz);    $ gets symbol name as sds
    1044
    1045
    1046$ general utility macros
    1047$ ----------------------
    1048
    1049      +*  symtype(nam)  =  $ type of symbol
    1050          ft_type(form(nam))
    1051          **
    1052
    1053
    1054      +*  symval(nam)  =  $ first word of value
    1055          val(vptr(nam))
    1056          **
    1057
    1058
    1059      +*  lines_max  =  $ number of lines between headings on dumps
    1060          20
    1061          **
    1062
    1063
    1064
    1065
    1066$ main program
    1067
    1068
    1069
    1070
    1071      call semini;   $ initialize
    1072
    1073      call binder;   $ bind previous compilations
    1074
    1075      call driver;   $ interpret polish string
    1076
    1077      call semtrm;  $ terminate
    1078
    1079
    1080
    1081
suna  21 .+r32 end prog stlsem;
suna  22 .+r36 end prog stlsem;
    1087 .+s66 end subr start;
       1 .=member semini
       2      subr semini;
       3
       4$ this routine is called to initialize the semantic pass. there
       5$ are four types of initialization performed:
       6
       7$ 1. read control card parameters
       8$ 2. open files and read initial tables
       9$ 3. initialize standard symtab amd formtab entries
      10$ 4. initialize codetab.
      11
      12
      13      size timestr(.sds. 30); $ current time and date
      14      size termh_flag(1);     $ print phase header on the terminal
      15
      16      size op(ps);            $ q1 opcode
      17      size ret(ps);           $ return code from dropsio and namesio
      18
      19$  get name of terminal file from little
      20
      21      term_title = '';
      22      call namesio(max_no_files, ret, term_title, filenamlen); $ errors
      23      if (ret > 1) term_title = '';        $ error, no term, or namesio
      24                                          $ not implemented
      25$ read control card options:
      26
      27 .+s10.
      28      call getspp(mpol_title, 'pol=pol/pol');     $ polish string
      29      call getspp(xpol_title, 'xpol=xpol/xpol');  $ aux polish str
      30      call getspp(bind_title, 'bind=0/bind');     $ binder input
      31      call getspp(ibnd_title, 'ibind=0/ibind');   $ ind bind input
      32      call getspp(q1_title,   'q1=q1/q1');        $ q1 output
      33      call getspp(sq1_title,  'sq1=0/sq1');       $ setl q1 output
      34 ..s10
      35
      36 .+s20.
      37      call getspp(mpol_title, 'pol=pol/pol');     $ polish string
      38      call getspp(xpol_title, 'xpol=xpol/xpol');  $ aux polish str
      39      call getspp(bind_title, 'bind=0/bind');     $ binder input
      40      call getspp(ibnd_title, 'ibind=0/ibind');   $ ind bind input
      41      call getspp(q1_title,   'q1=q1/q1');        $ q1 output
      42      call getspp(sq1_title,  'sq1=0/sq1');       $ setl q1 output
      43 ..s20
      44
      45
      46 .+s32.
      47      call getspp(mpol_title, 'pol=pol.tmp/');    $ polish string
      48      call getspp(xpol_title, 'xpol=xpol.tmp/');  $ aux polish str
      49      call getspp(bind_title, 'bind=0/bind.tmp'); $ binder input
      50      call getspp(ibnd_title,'ibind=0/ibind.tmp');$ ind bind input
      51      call getspp(q1_title,   'q1=q1.tmp/');      $ q1 output
      52      call getspp(sq1_title,  'sq1=0/sq1.tmp');   $ setl q1 output
      53 ..s32
      54
      55 .+s37cms.
      56      call getspp(mpol_title, 'pol=pol/pol');     $ polish string
      57      call getspp(xpol_title, 'xpol=xpol/xpol');  $ aux polish str
      58      call getspp(bind_title, 'bind=0/bind');     $ binder input
      59      call getspp(ibnd_title, 'ibind=0/ibind');   $ ind bind input
      60      call getspp(q1_title,   'q1=q1/q1');        $ q1 output
      61      call getspp(sq1_title,  'sq1=0/sq1');       $ setl q1 output
      62 ..s37cms
      63 .+s37mts.
      64      call getspp(mpol_title, 'pol=-setlpol/');   $ polish string
      65      call getspp(xpol_title, 'xpol=-setlxpol/'); $ aux. polish string
      66      call getspp(bind_title, 'bind=0/bind');     $ binder input
      67      call getspp(ibnd_title, 'ibind=0/ibind');   $ ind. binder input
      68      call getspp(q1_title,   'q1=-setlq1/');     $ little q1 file
      69      call getspp(sq1_title,  'sq1=0/-setlsq1');  $ setl q1 file
      70 ..s37mts
      71 .+s47.
      72      call getspp(mpol_title, 'pol=pol/pol');     $ polish string
      73      call getspp(xpol_title, 'xpol=xpol/xpol');  $ aux polish str
      74      call getspp(bind_title, 'bind=0/bind');     $ binder input
      75      call getspp(ibnd_title, 'ibind=0/ibind');   $ ind bind input
      76      call getspp(q1_title,   'q1=q1/q1');        $ q1 output
      77      call getspp(sq1_title,  'sq1=0/sq1');       $ setl q1 output
      78 ..s47
      79
      80 .+s66.
      81      call getspp(mpol_title, 'pol=pol/pol');     $ polish string
      82      call getspp(xpol_title, 'xpol=xpol/xpol');  $ aux polish str
      83      call getspp(bind_title, 'bind=0/bind');     $ binder input
      84      call getspp(ibnd_title, 'ibind=0/ibind');   $ ind bind input
      85      call getspp(q1_title,   'q1=q1/q1');        $ q1 output
      86      call getspp(sq1_title,  'sq1=0/sq1');       $ setl q1 output
      87 ..s66
suna  23
suna  24 .+s68.
suna  25      call getspp(mpol_title, 'pol=setl.pol/');   $ polish string
suna  26      call getspp(xpol_title, 'xpol=setl.xpol/'); $ aux polish str
suna  27      call getspp(bind_title, 'bind=0/bind');     $ binder input
suna  28      call getspp(ibnd_title, 'ibind=0/ibind');   $ ind bind input
suna  29      call getspp(q1_title,   'q1=setl.lq1/');    $ little q1 file
suna  30      call getspp(sq1_title,  'sq1=0/setl.sq1');  $ setl q1 file
suna  31 ..s68
      88
      89      call getipp(tre_flag,   'tre=0/1');   $ entry trace
      90      call getipp(trp_flag,   'trp=0/1');   $ trace polish string
      91      call getipp(trs_flag,   'trs=0/1');   $ trace astack
      92      call getipp(ur_flag,    'ur=0/1');    $ warning for unrepr'ed vars
      93      call getipp(uv_flag,    'uv=0/1');    $ warning for undeclared var
      94      call getipp(et_flag,    'et=0/1');    $ dump tables after error
      95      call getipp(chk_flag,   'chk=0/1');   $ check code fragments
      96      call getipp(q1sd_flag,  'sq1sd=0/1'); $ dump q1 symbol tables
      97      call getipp(q1cd_flag,  'sq1cd=0/1'); $ dump q1 code
      98      call getipp(sel,        'sel=1000/1000');
      99      call getipp(opt_flag,   'opt=0/1');   $ global optimization
     100      call getipp(rpr_flag,   'reprs=1/1'); $ process repr statements
     101      call getipp(sif_flag,   'sif=0/1');   $ save polish files
     102      call getipp(diter_flag, 'diter=0/1'); $ direct iteration
     103      call getipp(termh_flag, 'termh=0/1'); $ print phase header
sunb  14
sunb  15
sunb  16 .-s68.
sunb  17 .-s47.
sunb  18 .-s32u.
sunb  19      call getipp(lcp_flag,   'lcp=1/1');   $ list program parameters
sunb  20      call getipp(lcs_flag,   'lcs=1/1');   $ list program statistics
sunb  21 .+s32u.
sunb  22      call getipp(lcp_flag,   'lcp=0/1');   $ list program parameters
sunb  23      call getipp(lcs_flag,   'lcs=0/1');   $ list program statistics
sunb  24 ..s32u
sunb  25 .+s47.
sunb  26      call getipp(lcp_flag,   'lcp=0/1');   $ list program parameters
sunb  27      call getipp(lcs_flag,   'lcs=0/1');   $ list program statistics
sunb  28 ..s47
sunb  29 .+s68.
sunb  30      call getipp(lcp_flag,   'lcp=0/1');   $ list program parameters
sunb  31      call getipp(lcs_flag,   'lcs=0/1');   $ list program statistics
sunb  32 ..s68
sunb  33
     104
     105      $ initialize little trace
     106      if tre_flag then
     107          monitor entry, limit = 10000;
     108      else
     109          monitor noentry;
     110      end if;
     111
     112      $ open files
     113      file mpol_file   access = read,   title = mpol_title;
     114      file xpol_file   access = read,   title = xpol_title;
     115      file bind_file   access = read,   title = bind_title;
     116      file ibnd_file   access = get,    title = ibnd_title,
     117                       linesize = 80;
     118      file q1_file     access = write,  title = q1_title;
     119      file sq1_file    access = write,  title = sq1_title;
     120
     121      if (.len. term_title) call opnterm(term_title);
     122
     123      $ indicate which files can be deleted upon completion of sem
     124      if ^ sif_flag then
     125          call dropsio(mpol_file, ret);
     126          call dropsio(xpol_file, ret);
     127      end if;
     128
     129 .+s66.
     130      rewind mpol_file;   rewind xpol_file;   rewind bind_file;
     131      rewind q1_file;     rewind sq1_file;    rewind ibnd_file;
     132 ..s66
     133
     134      $ little reserves the file title '0' for a *sink*.  there is,
     135      $ however, no need for the setl user to know about this, and
     136      $ we therefore reset the bind- and sq1-titles to the null
     137      $ string if no such files were supplied by the user.
     138      if (bind_title .seq. '0') bind_title = '';
     139      if (ibnd_title .seq. '0') ibnd_title = '';
     140      if (sq1_title  .seq. '0') sq1_title  = '';
     141
     142      $ initialize listing control
     143      call contlpr( 6, yes);  $ start paging
     144      call contlpr( 7, yes);  $ enable titling
     145      call lstime(timestr);   $ get current time
     146      call etitlr(0, 'cims.setl.' .cc. prog_level,  1, 0);
     147      call etitlr(0,                      timestr, 41, 0);
     148      call etitlr(0,                       'page', 71, 0);
     149      call contlpr( 8,  76);  $ set page number in column 76
     150      call contlpr(13,   0);  $ set number of current page
sunb  34      call contlpr(10, ret);  $ get lines per page
sunb  35      call contlpr(15, ret);  $ set line number within page
     151
sunb  36    if lcp_flag then  $ print phase heading
sunb  37      put ,'parameters for this compilation: ' ,skip
     155          ,skip ,'polish string file: pol = '     :mpol_title ,a ,'. '
     156          ,skip ,'auxiliary string file: xpol = ' :xpol_title ,a ,'. '
     157          ,skip ,'binder file: bind = '           :bind_title ,a ,'. '
     158                ,'ind. bind file: ibind = '       :ibnd_title ,a ,'. '
     159          ,skip ,'little q1 file: q1 = '          :q1_title   ,a ,'. '
     160                ,'setl q1 file: sq1 = '           :sq1_title  ,a ,'. '
     161          ,skip ,'semantic error limit: sel = '   :sel        ,i ,'. '
     162                ,'semantic error file: term = '   :term_title ,a ,'. '
     163          ,skip ,'global optimisation: opt = '    :opt_flag   ,i ,'. '
     164                ,'user data structures: reprs = ' :rpr_flag   ,i ,'. '
     165          ,skip ,'direct iteration: diter = '     :diter_flag ,i ,'. '
     166          ,skip;
sunb  38    end if;
     167
     168      if termh_flag then
     169          $ the following line is printed on the terminal file only
     170          call contlpr(26, no);   call contlpr(27, yes);
     171          put ,'  start cims.setl.' ,prog_level :timestr ,a ,skip;
     172          call contlpr(26, yes);  call contlpr(27, no);
     173      end if;
     174
     175 .-sq1.
     176      if .len. sq1_title then
     177          put, skip, column(5); $ emit blank line, position next line
     178          call contlpr(27, yes);$ echo to the terminal
     179          put, '*** setl q1 interface not available ***', skip;
     180          call contlpr(27, no); $ stop to echo to the terminal
     181          call ltlfin(1, 0);
     182      end if;
     183 ..sq1
     184
     185$ initialize prefix_map.
     186
     187      +*  s(i, j, k) =  prefix_map(i, j) = k;  **
     188
     189      s(sym_local,    f_uset,   f_lset);
     190      s(sym_local,    f_umap,   f_lmap);
     191      s(sym_local,    f_uimap,  f_limap);
     192      s(sym_local,    f_urmap,  f_lrmap);
     193
     194      s(sym_packed,   f_tuple,  f_ptuple);
     195      s(sym_packed,   f_lmap,   f_lpmap);
     196      s(sym_packed,   f_rmap,   f_rpmap);
     197
     198      s(sym_remote,   f_uset,   f_rset);
     199      s(sym_remote,   f_umap,   f_rmap);
     200      s(sym_remote,   f_uimap,  f_rimap);
     201      s(sym_remote,   f_urmap,  f_rrmap);
     202
     203      s(sym_sparse,   f_uset,   f_uset);
     204      s(sym_sparse,   f_umap,   f_umap);
     205      s(sym_sparse,   f_uimap,  f_uimap);
     206      s(sym_sparse,   f_urmap,  f_urmap);
     207
     208      s(sym_untyped,  f_sint,   f_uint);
     209      s(sym_untyped,  f_int,    f_uint);
     210      s(sym_untyped,  f_real,   f_ureal);
     211
     212      macdrop(s);
     213
     214$ initialize the q1 tables
     215
     216      call inform;
     217      call inisym;
     218      call incode;
     219
     220
     221      end subr semini;
       1 .=member inform
       2      subr inform;
       3
       4$ this routine builds the standard entries for formtab. this
       5$ is simply a matter of iterating over the ft_type codes, hashing
       6$ in the proper entries.
       7
       8      size fm(ps);            $ form table pointer
       9      size j(ps);             $ loop index
      10
      11      do j = f_min to f_max;
      12          countup(formtabp, formtab_lim, 'formtabp');
      13
      14          formtab(formtabp) = 0;
      15          ft_type(formtabp) = j;
      16
      17$ fill in any special fields
      18
      19          if is_fmap(j) then  $ set mapc
      20              ft_mapc(formtabp) = ft_map;
      21              ft_elmt(formtabp)  = f_tuple;
      22              ft_imset(formtabp) = f_uset;
      23
      24              if is_fimap(j) then  $ untyped integer map
      25                  ft_im(j) = f_uint;
      26              elseif is_frmap(j) then  $ untyped real map
      27                  ft_im(j) = f_ureal;
      28              end if;
      29
      30          elseif is_ftup(j) then  $ keep nelt
      31              ft_neltok(j) = yes;
      32
      33              if j = f_ituple then
      34                  ft_elmt(j) = f_uint;
      35              elseif j = f_rtuple then
      36                  ft_elmt(j) = f_ureal;
      37              end if;
      38          end if;
      39
      40          fm = hashf1(0);
      41      end do;
      42
      43
      44      end subr inform;
       1 .=member inisym
       2      subr inisym;
       3
       4$ this routine initializes the symbol table.
       5
       6
       7      size fm(ps);            $ form table pointer
       8      size p(ps);             $ symtab pointer
       9      size j(ps);             $ loop index
      10
      11      size digit(.sds. 1);    $ digits as stringds
      12      dims digit(10);
      13      data digit = '0', '1', '2', '3', '4', '5', '6', '7', '8', '9';
      14
      15      size genst(ps);         $ builds sets and tuples
      16      size getint(ps);        $ returns symbol table entry for integer
      17
      18
      19$ the standard symbols are arranged in several strings, separated
      20$ by blanks. we call 'inistd' to process each string.
      21
      22      $ system defined modes
      23      call inistd('general integer real string boolean atom ');
      24      call inistd('error elmt tuple set map smap mmap ');
      25
      26      $ base type keywords
      27      call inistd('local remote sparse packed untyped ');
      28
      29      $ read-write keywords
      30      call inistd('rd wr rw ');
      31
      32      $ keywords for rights lists
      33      call inistd('libraries reads writes imports exports ');
      34
      35      $ system defined binary operators
      36      call inistd('impl or and in notin incs subset < <= > >= = /= ');
      37      call inistd('with from fromb frome less lessf ');
      38      call inistd('npow min max + - * / div mod ? atan2 ** ');
      39
      40      $ system define unary operators
      41      call inistd('not even odd is_integer is_real is_string ');
      42      call inistd('is_boolean is_atom is_tuple ');
      43      call inistd('is_set is_map arb domain range pow # ');
      44      call inistd('abs char ceil floor fix float sin cos tan ');
      45      call inistd('asin acos atan tanh exp log sqrt random ');
      46      call inistd('sign type str val ');
      47
      48      $ compiler debugging options
      49      call inistd('ptrm0 ptrm1 ptrp0 ptrp1 ptrt0 ptrt1 ');
      50      call inistd('prsod prspd prssd ');
      51      call inistd('stre0 stre1 strs0 strs1 sq1cd sq1sd scstd ');
      52      call inistd('cq1cd cq1sd cq2cd ');
      53      call inistd('rtre0 rtre1 rtrc0 rtrc1 ');
      54      call inistd('rtrg0 rtrg1 rgcd0 rgcd1 rdump rgarb ');
      55
      56      $ user trace options
      57      call inistd('calls statements ');
      58
      59      $ system constants
      60      call inistd('''integer'' ''real'' ''string'' ');
      61      call inistd('''boolean'' ''atom'' ''tuple'' ''set'' ');
      62      call inistd('om s$nullset s$nulltup s$nullstr true false ');
      63
      64      $ initialize standard integers.
      65      do j = 1 to 10;
      66          push1(hashst(digit(j))); call gint; free_stack(1);
      67      end do;
      68
      69
      70      $ misc. symbols
      71      call inistd('_main ');
      72
      73      $ the run time library uses several special variables with
      74      $ with primal scope.  call gvar to process them.
      75      push1(hashst('s$t1'));  $ used by copy routine
      76      push1(hashst('s$t2'));
      77      push1(hashst('s$t3'));
      78      push1(hashst('s$t4'));
      79
      80      push1(hashst('s$okval')); $ result of 'ok'
      81
      82      push1(hashst('s$fid'));   $ map on file names
      83      push1(hashst('s$free'));  $ set of free file ids
      84      push1(hashst('s$fmax'));  $ maximum file id
      85      push1(hashst('s$fmode')); $ map on file modes
      86
      87      push1(hashst('s$io1'));   $ io work areas
      88      push1(hashst('s$io2'));
      89
      90      push1(hashst('s$stat')); $ tuple for performance measurements
      91
      92      push1(hashst('s$ss1'));  $ string specifier one
      93      push1(hashst('s$ss2'));  $ string specifier two
      94
      95      push1(hashst('s$ovar'));   $ packed tuple for q2 ops_ovar
      96      push1(hashst('s$scopes')); $ packed tuple for variable tracing
      97      push1(hashst('s$rnspec')); $ untyped tuple for runtime names spec
      98      push1(hashst('s$rnames')); $ character string for run-time names
      99      push1(hashst('s$intf'));   $ fortran interface tuple
     100      push1(hashst('s$spare2')); $ and testing of new features
     101      push1(hashst('s$spare3'));
     102      push1(hashst('s$spare4'));
     103      push1(hashst('s$spare5'));
     104      push1(hashst('s$spare6'));
     105      push1(hashst('s$spare7'));
     106      push1(hashst('s$spare8'));
     107      push1(hashst('s$spare9'));
     108      push1(hashst('s$sparea'));
     109      push1(hashst('s$spareb'));
     110      push1(hashst('s$sparec'));
     111      push1(hashst('s$spared'));
     112      push1(hashst('s$sparee'));
     113      push1(hashst('s$sparef'));
     114      push1(hashst('s$spareg'));
     115      push1(hashst('s$spareh'));
     116      push1(hashst('s$sparei'));
     117      push1(hashst('s$sparej'));
     118      push1(hashst('s$sparek'));
     119
     120      push1(37);                 $ number of library variables hereabove
     121                                 $ added to the symbol table
     122      call gnobk;
     123      call gvar;
     124
     125
     126      $ built in procedures
     127      call inistd('open close print read printa reada get put ');
     128      call inistd('getb putb getk putk getf callf putf rewind eof ');
     129      call inistd('eject title getipp getspp ');
     130      call inistd('getem setem ');
     131      call inistd('host ');
     132      call inistd('span break match lpad len any notany ');
     133      call inistd('rspan rbreak rmatch rpad rlen rany rnotany ');
     134
     135
     136      $ initialize system constants
     137      do j = sym_int to sym_set;
     138          push1(j); call gstr; free_stack(1);
     139      end do;
     140
     141      $ declare 'om' like a read only variable.
     142      is_decl(sym_om)  = yes;
     143      is_read(sym_om)  = yes;
     144      is_repr(sym_om)  = yes;
     145      is_store(sym_om) = yes;
     146
     147      push2(sym_nulltup, genst(q1_tup, 0));   call gcnst1;
     148      push2(sym_nullset, genst(q1_set, 0));   call gcnst1;
     149      push2(sym_nullstr, hashst(2q''));  call gstr;  call gcnst1;
     150
     151
     152      $ initialize true and false as short atoms 0 and maxsi, resp.
     153      is_repr(sym_true) = yes;   is_decl(sym_true) = yes;
     154      is_read(sym_true) = yes;   is_store(sym_true) = yes;
     155      form(sym_true) = f_atom;
     156      countup(valp, val_lim, 'val');   val(valp) = 0;
     157      vptr(sym_true) = valp;   vlen(sym_true) = 1;
     158
     159      is_repr(sym_false) = yes;   is_decl(sym_false) = yes;
     160      is_read(sym_false) = yes;   is_store(sym_false) = yes;
     161      form(sym_false) = f_atom;
     162      countup(valp, val_lim, 'val');   val(valp) = maxsi;
     163      vptr(sym_false) = valp;   vlen(sym_false) = 1;
     164
     165      $ build form table entry for 'tuple(general)(2)'
smfa  13      push2(f_gen, sym_two); call gttup2; pop1(fm);
     167      assert fm = f_pair;
     168
     169      $ build form table entry for 'packed tuple(integer 1..1)'
     170      push1(sym_packed);
     171      push3(sym_mint, sym_one, sym_one); call gtint;
     172      push1(sym_zero); call gttup2; call gtpref; pop1(fm);
     173      assert fm = f_pt11;
     174
     175      $ build form table entry for 'packed tuple(integer 1..pset_lim)'
     176      push1(sym_packed);
     177      push3(sym_mint, sym_one, getint(pset_lim)); call gtint;
     178      push1(sym_zero); call gttup2; call gtpref; pop1(fm);
     179      assert fm = f_pset;
     180
     181      $ declare builtin procedures and main program
     182      call inbip1;
     183
     184      user_org = symtabp;    $ point to zero-th symbol supplied by user
     185
     186      call gputtb;            $ write out system scope
     187
     188
     189      end subr inisym;
       1 .=member inbip1
       2      subr inbip1;
       3
       4$ this routine initializes the built in procedures. this is done in
       5$ two steps: first we declare the procedures, then we repr them.
       6
       7
       8      +* s(nam, n, m1, m2, m3, var)  =  $ declare procedure
       9          call inbip2(nam, n, m1, m2, m3, var);
      10          **
      11
smfb 104      s(sym_open,    2,  sym_rd,  sym_rd,  0,       no );
smfb 105      s(sym_close,   1,  sym_rd,  0,       0,       no );
      14      s(sym_print,   1,  sym_rd,  0,       0,       yes);
      15      s(sym_read,    1,  sym_wr,  0,       0,       yes);
      16      s(sym_printa,  2,  sym_rd,  sym_rd,  0,       yes);
      17      s(sym_reada,   2,  sym_rd,  sym_wr,  0,       yes);
      18      s(sym_get,     2,  sym_rd,  sym_wr,  0,       yes);
      19      s(sym_put,     2,  sym_rd,  sym_rd,  0,       yes);
      20      s(sym_getb,    2,  sym_rd,  sym_wr,  0,       yes);
      21      s(sym_putb,    2,  sym_rd,  sym_rd,  0,       yes);
      22      s(sym_getk,    2,  sym_rd,  sym_wr,  0,       no );
      23      s(sym_putk,    2,  sym_rd,  sym_rd,  0,       no );
      24      s(sym_getf,    2,  sym_rd,  sym_wr,  0,       yes);
      25      s(sym_callf,   3,  sym_rd,  sym_rd,  sym_rd,  no );
      26      s(sym_putf,    2,  sym_rd,  sym_rd,  0,       yes);
      27      s(sym_rewind,  1,  sym_rd,  0,       0,       no );
      28      s(sym_eof,     0,  0,       0,       0,       no );
      29      s(sym_eject,   1,  sym_rd,  0,       0,       yes);
      30      s(sym_title,   1,  sym_rd,  0,       0,       yes);
      31
      32      s(sym_getipp,  1,  sym_rd,  0,       0,       no );
      33      s(sym_getspp,  1,  sym_rd,  0,       0,       no );
      34      s(sym_getem,   2,  sym_wr,  sym_wr,  0,       no );
      35      s(sym_setem,   2,  sym_rd,  sym_rd,  0,       no );
      36
      37      s(sym_host,    1,  sym_rd,  0,       0,       yes);
      38
      39      s(sym_span,    2,  sym_rw,  sym_rd,  0,       no );
      40      s(sym_break,   2,  sym_rw,  sym_rd,  0,       no );
      41      s(sym_match,   2,  sym_rw,  sym_rd,  0,       no );
      42      s(sym_lpad,    2,  sym_rd,  sym_rd,  0,       no );
      43      s(sym_len,     2,  sym_rw,  sym_rd,  0,       no );
      44      s(sym_any,     2,  sym_rw,  sym_rd,  0,       no );
      45      s(sym_notany,  2,  sym_rw,  sym_rd,  0,       no );
      46
      47      s(sym_rspan,   2,  sym_rw,  sym_rd,  0,       no );
      48      s(sym_rbreak,  2,  sym_rw,  sym_rd,  0,       no );
      49      s(sym_rmatch,  2,  sym_rw,  sym_rd,  0,       no );
      50      s(sym_rpad,    2,  sym_rd,  sym_rd,  0,       no );
      51      s(sym_rlen,    2,  sym_rw,  sym_rd,  0,       no );
      52      s(sym_rany,    2,  sym_rw,  sym_rd,  0,       no );
      53      s(sym_rnotany, 2,  sym_rw,  sym_rd,  0,       no );
      54
      55      s(sym_main_,   0,  0,       0,       0,       no );
      56
      57      macdrop(s)
      58
      59
      60      +* s(nam, n, f1, f2, f3, f4)  =  $ repr procedure
      61          call inbip3(nam, n, f1, f2, f3, f4);
      62          **
      63
      64
      65      s(sym_open,    2,  f_string,  f_string,  0,       f_atom  );
smfb 106      s(sym_close,   1,  f_string,  0,         0,       f_gen   );
      67      s(sym_print,   1,  f_gen,     0,         0,       f_gen   );
      68      s(sym_read,    1,  f_gen,     0,         0,       f_gen   );
      69      s(sym_printa,  2,  f_string,  f_gen,     0,       f_gen   );
      70      s(sym_reada,   2,  f_string,  f_gen,     0,       f_gen   );
      71      s(sym_get,     2,  f_string,  f_string,  0,       f_gen   );
      72      s(sym_put,     2,  f_string,  f_string,  0,       f_gen   );
      73      s(sym_getb,    2,  f_string,  f_gen,     0,       f_gen   );
      74      s(sym_putb,    2,  f_string,  f_gen,     0,       f_gen   );
      75      s(sym_getk,    2,  f_string,  f_gen,     0,       f_gen   );
      76      s(sym_putk,    2,  f_string,  f_gen,     0,       f_gen   );
      77      s(sym_getf,    2,  f_sint,    f_gen,     0,       f_gen   );
      78      s(sym_callf,   3,  f_sint,    f_sint,    f_sint,  f_gen   );
      79      s(sym_putf,    2,  f_sint,    f_gen,     0,       f_gen   );
      80      s(sym_rewind,  1,  f_string,  0,         0,       f_gen   );
      81      s(sym_eof,     0,  0,         0,         0,       f_atom  );
      82      s(sym_eject,   1,  f_gen,     0,         0,       f_gen   );
      83      s(sym_title,   1,  f_gen,     0,         0,       f_gen   );
      84
      85      s(sym_getipp,  1,  f_string,  0,         0,       f_int   );
      86      s(sym_getspp,  1,  f_string,  0,         0,       f_string);
      87      s(sym_getem,   2,  f_sint,    f_sint,    0,       f_gen   );
      88      s(sym_setem,   2,  f_sint,    f_sint,    0,       f_gen   );
      89
      90      s(sym_host,    1,  f_gen,     0,         0,       f_gen);
      91
      92      s(sym_span,    2,  f_string,  f_string,  0,       f_string);
      93      s(sym_break,   2,  f_string,  f_string,  0,       f_string);
      94      s(sym_match,   2,  f_string,  f_string,  0,       f_string);
      95      s(sym_lpad,    2,  f_string,  f_sint,    0,       f_string);
      96      s(sym_len,     2,  f_string,  f_sint,    0,       f_string);
      97      s(sym_any,     2,  f_string,  f_string,  0,       f_string);
      98      s(sym_notany,  2,  f_string,  f_string,  0,       f_string);
      99
     100      s(sym_rspan,   2,  f_string,  f_string,  0,       f_string);
     101      s(sym_rbreak,  2,  f_string,  f_string,  0,       f_string);
     102      s(sym_rmatch,  2,  f_string,  f_string,  0,       f_string);
     103      s(sym_rpad,    2,  f_string,  f_sint,    0,       f_string);
     104      s(sym_rlen,    2,  f_string,  f_sint,    0,       f_string);
     105      s(sym_rany,    2,  f_string,  f_string,  0,       f_string);
     106      s(sym_rnotany, 2,  f_string,  f_string,  0,       f_string);
     107
     108
     109      macdrop(s)
     110
     111
     112      user_org = symtabp;    $ point to zero-th symbol supplied by user
     113
     114
     115      end subr inbip1;
       1 .=member inbip2
       2      subr inbip2(nam, n, m1, m2, m3, vary);
       3
       4$ this routine initializes the symbol table entry for a built in
       5$ procedure. its arguments are:
       6
       7      size nam(ps),   $ procedure name
       8           n(ps),     $ number of arguments
       9           m1(ps),    $ mode for first argument
      10           m2(ps),    $ mode for second argument
      11           m3(ps),    $ mode for third argument
      12           vary(1);  $ indicates variable number of arguments
      13
      14$ we jump on the number of arguments and make an appropriate call
      15$ to prcdcl.
      16
      17      push1(nam);
      18
      19      go to case(n) in 0 to 3;
      20
      21/case(0)/
      22
      23      go to esac;
      24
      25/case(1)/
      26
      27      push1(m1);
      28      go to esac;
      29
      30/case(2)/
      31
      32      push2(m1, m2);
      33      go to esac;
      34
      35/case(3)/
      36
      37      push3(m1, m2, m3);
      38      go to esac;
      39
      40/esac/
      41
      42      call prcdcl(n, vary);
      43      free_stack(1);
      44
      45
      46      end subr inbip2;
       1 .=member inbip3
       2      subr inbip3(nam, n, f1, f2, f3, f4);
       3
       4$ this routine sets the repr for a built in procedure.
       5
       6      size nam(ps),   $ procedure name
       7           n(ps),     $ number of arguments
       8           f1(ps),    $ form of first argument
       9           f2(ps),    $ form of third argument
      10           f3(ps),    $ form of third argument
      11           f4(ps);    $ form of result
      12
      13      size tp(ps);    $ type of procedure
      14
      15$ we jump on the number of arguments and make an appropriate call
      16$ to rproc.
      17
      18
      19      go to case(n) in 0 to 3;
      20
      21/case(0)/
      22
      23      push1(f4);   call gtprc4;   pop1(tp);
      24      call rproc(nam, tp);
      25      return;
      26
      27/case(1)/
      28
      29      push1(f1);
      30      go to esac;
      31
      32/case(2)/
      33
      34      push2(f1, f2);
      35      go to esac;
      36
      37/case(3)/
      38
      39      push3(f1, f2, f3);
      40      go to esac;
      41
      42/esac/
      43
      44      push2(n-1, f4);   call gtprc1;   pop1(tp);
      45      call rproc(nam, tp);
      46
      47
      48      end subr inbip3;
       1 .=member inistd
       2      subr inistd(string);
       3
       4$ this routine hashes a series of standard symbols into the symbol
       5$ table. the symbols are arranged in a string, seperted by blanks.
       6
       7      size string(sds_sz);  $ string containing symbols
       8
       9      size first(ps),   $ points to start of string
      10           last(ps),    $ points to blank after string
      11           len(ps),     $ length of string
      12           p(ps);             $ pointer returned by hashst
      13
      14
      15      first = 1;   $ pointer to start of symbol
      16      len = .len. string;
      17
      18      while first <= len;
      19          last = first + 1;
      20
      21          while .ch. last, string ^= 1r ;
      22              last = last + 1;
      23          end while;
      24
      25          p = hashst(.s. first, last-first, string);
      26
      27          first = last + 1;
      28      end while;
      29
      30
      31      end subr inistd;
       1 .=member incode
       2      subr incode;
       3
       4$ this routine initializes codetab, argtab, and blocktab.
       5
       6$ the code for each routine starts with a noop instruction.
       7$ both prog_start and prog_end are set to point to this
       8$ instruction.
       9
      10$ initialize pointers
      11      argtab_org   = 0;
      12      codetab_org  = 0;
      13      blocktab_org = 0;
      14
      15      argtabp   = 0;
      16      blocktabp = 0;
      17      codetabp  = 1;
      18
      19$ install noop
      20      codetab(codetabp) = 0;
      21      opcode(codetabp)  = q1_noop;
      22
      23      prog_start = codetabp;
      24      prog_end   = codetabp;
      25
      26
      27      end subr incode;
       1 .=member driver
       2      subr driver;
       3
       4$ this is the main driving routine for the semantic pass. it
       5$ iterates over the polish string, performing the appropriate
       6$ action for each node.
       7
       8      size tp(ps),   $ type of node
       9           vl(ps),    $ value of node
      10           nam(ps);    $ symtab pointer
      11
      12      size ara(ws);   $ array for new names entry
      13      dims ara(sds_sz/ws);
      14
      15
      16
      17      while 1;
      18          getp(tp, vl);
      19          if (filestat(pol_file, end)) quit;
      20
      21          go to case(tp) in pol_min to pol_max;
      22
      23      /case(pol_name)/  $ hash name and push onto astack
      24
      25          read pol_file, ara(1) to ara(vl);
      26          nam = hash(ara, vl);
      27
      28          push1(nam);
      29          cont;
      30
      31      /case(pol_count)/    $ push counter
      32
      33          push1(vl);
      34          cont;
      35
      36      /case(pol_mark)/  $ call semantic routine
      37
      38          call actgen(vl);
      39          cont while 1;
      40
      41      /case(pol_end)/         $ end-of-file
      42
      43          quit while 1;
      44
      45      end while;
      46
      47      end subr driver;
       1 .=member gsw1
       2      subr gsw1;
       3
       4$ this routine switches to the main polish file.
       5
       6      pol_file = mpol_file;
       7
       8
       9      end subr gsw1;
       1 .=member gsw2
       2      subr gsw2;
       3
       4$ this routine switches to the auxiliary polish file.
       5
       6      pol_file = xpol_file;
       7
       8
       9      end subr gsw2;
       1 .=member actgen
       2      subr actgen(c);
       3
       4$ this routine calls the various generator routine corresponding to
       5$ marker nodes. it is based on the following macro which expands the
       6$ output of 'syn':
       7
       8      +*  synsemmap(a, b) =
       9          /case(a)/  call b;   go to esac;
      10          **
      11
      12      size c(ps);
      13
      14      go to case(c) in 1 to parseimpmax;
      15
      16 .=include 'synsem'
      17
      18/esac/
      19
      20
      21      end subr actgen;
       1 .=member gdirct
       2      subr gdirct;
       3
       4$ this routine opens a new directory
       5
       6
       7      pop1(curdir);
       8
       9      $ the symbol table entry for a directory is the first entry in its
      10      $ own scope.
      11      if ( ^ is_local(curdir)) call ermsg(92, curdir);
      12
      13      call gmemb(curdir, unit_dir);
      14
      15
      16      end subr gdirct;
       1 .=member gprog1
       2      subr gprog1;
       3
       4$ this routine is called after seeing the directory name in a
       5$ 'program' statement.  we treat it as if we were processing a
       6$ module statement.
       7
       8
       9      call gmod1;
      10
      11
      12      end subr gprog1;
       1 .=member gprog2
       2      subr gprog2;
       3
       4$ this routine is called after seeing 'program xxx - yyy'.  we
       5$ pop the program name, set the unit type and add the main
       6$ program to proctab.
       7
       8
       9      size nam(ps);  $ program name
      10
      11
      12      pop1(nam);
      13
      14      if ^ is_decl(nam) then
      15          call ermsg(90, nam);
      16          call semtrm;
      17      end if;
      18
      19      call gmemb(nam, unit_prog);
      20
      21      countup(proctabp, proctab_lim, 'proctab');
      22      proctab(proctabp) = sym_main_;
      23
      24
      25      end subr gprog2;
       1 .=member gprog3
       2      subr gprog3;
       3
       4$ this routine is called after seeing 'program xxx;'.  it is
       5$ similar to gprog2 except that we check that there is no
       6$ directory.
       7
       8
       9      size nam(ps);           $ program name
      10
      11
      12      if curdir ^= 0 then
      13          call ermsg(66, curdir);
      14          call semtrm;
      15
      16      else
      17          pop1(nam);
      18
      19          $ the symbol table entry for the program scope of a simple
      20          $ program is the first entry in its own scope.
      21          if ( ^ is_local(nam)) call ermsg(93, nam);
      22
      23          call gmemb(nam, unit_prog);
      24
      25          countup(proctabp, proctab_lim, 'proctab');
      26          proctab(proctabp) = sym_main_;
      27      end if;
      28
      29
      30      end subr gprog3;
       1 .=member glib
       2      subr glib;
       3
       4$ this routine processes the library statement. it is similar to gprog.
       5
       6      size nam(ps);           $ library name
       7
       8
       9      pop1(nam);
      10
      11      $ the symbol table entry for a library is the first entry in its
      12      $ own scope.
      13      if ( ^ is_local(nam)) call ermsg(94, nam);
      14
      15      call gmemb(nam, unit_lib);
      16
      17
      18      end subr glib;
       1 .=member gmod1
       2      subr gmod1;
       3
       4$ this routine is called after seeing the directory name in
       5$ a module statement.
       6
       7$ we begin by checking whether we have alreay seen a directory. if so,
       8$ we check that it is the same one; otherwise we read it in.
       9
      10
      11      size nam(ps);  $ name of program
      12
      13
      14      pop1(nam);
      15
      16      if curdir = 0 then  $ read it in
      17          curdir = nam;
      18          curunit = nam;
      19          if (^ is_seen(nam)) call ermsg(78, nam);
      20
      21      elseif nam ^= curdir then
      22          call ermsg(46, 0);
      23          call semtrm;
      24      end if;
      25
      26
      27      end subr gmod1;
       1 .=member gmod2
       2      subr gmod2;
       3
       4$ this routine is called after seeing the module name in a module
       5$ statement.  it is similar to glib and gprog.
       6
       7$ note that the scope of a module is its program.
       8
       9
      10      size nam(ps);  $ name of module
      11
      12
      13      pop1(nam);
      14
      15      if ^ is_decl(nam) then
      16          call ermsg(91, nam);
      17          call semtrm;
      18      end if;
      19
      20      call gmemb(nam, unit_mod);
      21
      22
      23      end subr gmod2;
       1 .=member gmemb
       2      subr gmemb(nam, mode);
       3
       4$ this routine opens a new member. nam is the name of the member, and mo
       5$ is its type.
       6
       7
       8      size nam(ps),  $ name of member
       9           mode(ps); $ compilation mode
      10
      11
      12      curmemb = nam;
      13      curunit = nam;
      14
      15      if (is_seen(nam)) call ermsg(23, nam); $ duplicate member
      16
      17      is_decl(nam) = yes;
      18      is_repr(nam) = yes;
      19      is_seen(nam) = yes;
      20      form(nam)    = f_memb;
      21
      22      unit_type = mode;
      23      memb_type = mode;
      24
      25      proctabp = 0;  $ initialize proctab
      26
      27
      28      end subr gmemb;
       1 .=member ghead1
       2      subr ghead1;
       3
       4$ this routine is called at the start of each header to initialize
       5$ various globals.
       6
       7
       8      size j(ps);   $ loop index
       9
      10
      11      head_tot = 0;
      12
      13      do j = sym_rts_min to sym_rts_max;
      14          rt_len(j) = 0;
      15      end do;
      16
      17
      18      end subr ghead1;
       1 .=member ghead2
       2      subr ghead2;
       3
       4$ this routine is called after seeing the name of a rights list.
       5$ we pop the name and store it in 'cur_rt'.
       6
       7
       8      pop1(cur_rt);
       9
      10
      11      end subr ghead2;
       1 .=member ghead3
       2      subr ghead3;
       3
       4$ this routine is called after seeing a name in a rights list. we
       5$ push the name of the rights list onto astack and increment various
       6$ counters.
       7
       8
       9      push1(cur_rt);
      10
      11      head_tot       = head_tot + 1;
      12      rt_len(cur_rt) = rt_len(cur_rt) + 1;
      13
      14
      15      end subr ghead3;
       1 .=member ghead4
       2      subr ghead4;
       3
       4$ this routine is called after seeing the keyword 'all' in a rights
       5$ list. we iterate over all the global variables calling ghead3.
       6
       7
smfb 107      size save_cur_rt(ps);   $ local copy of cur_rt
smfb 108      size j(ps);             $ loop index
       9
      10
smfb 109      if cur_rt = sym_libs then
smfb 110          $ meaningless since only  between gsym_org+1 and gsymp.
smfb 111          $ (strictly speaking a grammar bug:  extra production needed.)
smfb 112          call ermsg(98, 0);
smfb 113          return;
smfb 114      end if;
smfb 115
smfb 116      save_cur_rt = cur_rt;
      11      do j = gsym_org+1 to gsymp;
      12          if (is_internal(j)) cont;
      13
smfb 117          if is_const(j) then $ pretend that this is -reads <*name> ;-
smfb 118              cur_rt = sym_reads; push1(j); call ghead3;
smfb 119          else
smfb 120              cur_rt = save_cur_rt; push1(j); call ghead3;
smfb 121          end if;
      16      end do;
smfb 122
smfb 123      cur_rt = save_cur_rt;
      17
      18
      19      end subr ghead4;
       1 .=member ghead5
       2      subr ghead5;
       3
       4$ this routine builds a val entry for a header and sets two global
       5$ variables to point to it.
       6
       7$ at this point astack contains head_tot pairs [right, name]. we
       8$ begin by sorting these pairs first by right then by name. we
       9$ then pop the pairs and move the names into val.
      10
      11
      12      size vp(ps),            $ val pointer
      13           len(ps),           $ length of rights list
      14           rt(ps),            $ right
      15           nam(ps),           $ name
      16           i(ps),             $ loop index
      17           j(ps);             $ loop index
      18
      19
      20      call sorthd;
      21
      22      head_ptr = valp + 1;
      23      head_len = head_tot + 5;  $ for lengths of five lists
      24
      25      valp = valp + head_len;
      26      if (valp > val_lim) call overfl('val');
      27
      28
      29$ we use two loops to move the names into val, one over rights,
      30$ and the other over the length of each rights list.
      31      vp = head_ptr-1;
      32
      33      do i = sym_rts_min to sym_rts_max;
      34          len = rt_len(i);
      35
      36          vp = vp + 1;
      37          val(vp) = len;
      38
      39          do j = 1 to len;
      40              pop2(rt, nam);
      41
      42              vp = vp + 1;
      43              val(vp) = nam;
      44          end do;
      45      end do;
      46
      47
      48      end subr ghead5;
       1 .=member ghead6
       2      subr ghead6;
       3
       4$ this routine is called after seeing the  list for the
       5$ current member. there are four possibilities:
       6
       7$ 1. we are compiling a library.  install the new rights list as
       8$    the val entry for the current member.
       9
      10$ 2. we are compiling a module, and it contains a null header.
      11$    in this case we simply use the header supplied for it in
      12$    the directory.
      13
      14$ 3. we are compiling a module and it contains a non-null header.
      15$    we compare the header with the one given in the directory.
      16
      17$ 4. we are processing a main program and there is no directory.
      18$    make sure the rights list only includes libraries.
      19
      20$ once we have processed the appropriate case we call 'sethd' to
      21$ absorb the rights lists.
      22
      23
      24      size p(ps),             $ old vptr for module
      25           l(ps),             $ old vlen for module
      26           j(ps);             $ loop index
      27
      28
      29      if memb_type = unit_lib then
      30          vptr(curmemb) = head_ptr;
      31          vlen(curmemb) = head_len;
      32
      33      elseif memb_type = unit_prog & curdir = 0 then
      34          $ recall that val(head_ptr) = number of libraries
      35          if (head_len ^= val(head_ptr) + 5) go to no_match;
      36
      37          vptr(curmemb) = head_ptr;
      38          vlen(curmemb) = head_len;
      39
      40      elseif head_len ^= 5 then  $ non-null header
      41
      42          p = vptr(curmemb);   $ val entry from main program
      43          l = vlen(curmemb);
      44
      45          if (head_len ^= l) go to no_match;  $ wrong length
      46
      47          do j = 0 to head_len-1;
      48              if (val(p+j) ^= val(head_ptr+j)) go to no_match;
      49          end do;
      50      end if;
      51
      52      call sethd;
      53
      54      return;
      55
      56
      57/no_match/     $ headers dont match
      58
      59      call ermsg(37, 0);
      60
      61      return;
      62
      63
      64      end subr ghead6;
       1 .=member ghead7
       2      subr ghead7;
       3
       4$ this routine is called after seeing a module descriptor in a
       5$ directory.  we install the current header as the val entry for
       6$ the module.
       7
       8
       9      size mod(ps),  $ module name
      10           dir(ps);
      11
      12
      13      pop2(mod, dir);
      14
      15      if (dir ^= curdir) call ermsg(46, 0);
      16
      17      if is_decl(mod) then
      18          call ermsg(38, mod);
      19
      20      else
      21          is_decl(mod) = yes;
      22          is_repr(mod) = yes;
      23          vptr(mod)    = head_ptr;
      24          vlen(mod)    = head_len;
      25          form(mod)    = f_memb;
      26      end if;
      27
      28
      29      end subr ghead7;
       1 .=member sorthd
       2      subr sorthd;
       3
       4$ this routine sorts the astack entries for a header. the top
       5$ head_tot entries are pairs [right, name]. we sort them first
       6$ by right then by name with the smallest value closest to
       7$ the top of the stack. we use a bubble sort.
       8
       9      size i(ps),   $ loop index
      10           j(ps);   $ loop index
      11
      12      +*  rt(i)  =  $ i-th right name
      13          astack(asp - 2 * (i) + 2)
      14          **
      15
      16      +*  nm(i)  =  $ i-th name
      17          astack(asp - 2 * (i) + 1)
      18          **
      19
      20      do i = 2 to head_tot;
      21          do j = i-1 to 1 by -1;
      22
      23              if (rt(j) < rt(j+1)) quit;
      24
      25              if (rt(j) = rt(j+1) & nm(j) < nm(j+1)) quit;
      26
      27              swap(rt(j), rt(j+1));
      28              swap(nm(j), nm(j+1));
      29          end do;
      30      end do;
      31
      32      macdrop(rt)
      33      macdrop(nm)
      34
      35      return;
      36
      37      end subr sorthd;
       1 .=member sethd
       2      subr sethd;
       3
       4$ this routine processes the header for the current member,
       5$ absorbing its libs, reads, writes, and exports lists.
       6
       7
       8      size org(ps);           $ origin in val
       9      size n(ps);             $ number of words in list
      10      size nam(ps);           $ variable name
      11      size j(ps);             $ loop index
      12
      13      size org1(ps);          $ origin for library
      14      size n1(ps);            $ length for library
      15      size j1(ps);            $ index for library
      16      size nam1(ps);          $ name in library
      17
      18$
      19$ begin by clearing the is_read, is_write, and is_avail flags
      20$ from the previous module.
      21$
      22      do j = user_org + 1 to symtabp;
      23          is_read(j)  = no;
      24          is_write(j) = no;
      25          is_avail(j) = no;
      26      end do;
      27$
      28$ process all libraries mentioned in header
      29$
      30      org = vptr(curmemb);    $ point to zero-th library
      31      n   = val(org);         $ number of libraries
      32
      33      do j = 1 to n;
      34          nam = val(org+j);
      35          if (^ is_seen(nam)) call ermsg(78, nam);
      36          $
      37          $ find the library's exported procedures and set their
      38          $ is_avail bits.  we begin by crawling through the
      39          $ library's val entry, looking for its exported procedures.
      40          $
      41          org1 = vptr(nam);
      42          n1   = val(org1);
      43
      44          do j1 = 1 to 4;     $ skip libs, reads, and writes lists
      45              org1 = org1 + n1 + 1;
      46              n1   = val(org1);
      47          end do;
      48
      49          do j1 = 1 to n1;    $ set is_avail bits
      50              nam1 = val(org1 + j1);
      51              is_avail(nam1) = yes;
      52          end do;
      53      end do;
      54$
      55$ process reads variables
      56$
      57      org = org + n + 1;      $ zero-th reads variable
      58      n   = val(org);         $ number of reads variables
      59
      60      if (memb_type = unit_lib & n ^= 0) call ermsg(63, 0);
      61
      62      do j = 1 to n;
      63          nam = val(org+j);
      64          if (^ is_decl(nam)) call ermsg(79, nam);
      65
      66          is_read(nam) = yes;
      67      end do;
      68$
      69$ repeat for writes variables.
      70$
      71      org = org + n + 1;      $ zero-th writes variable
      72      n   = val(org);         $ number of writes variables
      73
      74      if (memb_type = unit_lib & n ^= 0) call ermsg(63, 0);
      75
      76      do j = 1 to n;
      77          nam = val(org+j);
      78          if (^ is_decl(nam)) call ermsg(80, nam);
      79
      80          is_read(nam) = yes;
      81          is_write(nam) = yes;
      82      end do;
      83$
      84$ process the imports list, indicating that they are available to be
      85$ called.
      86$
      87      org  = org + n + 1;
      88      n = val(org);
      89
      90      do j = 1 to n;
      91          nam = val(org+j);
      92          is_avail(nam) = yes;
      93      end do;
      94$
      95$ process the exports list, adding each procedure to proctab and
      96$ indicating that it is available to be called.
      97$
      98      org = org + n + 1;
      99      n = val(org);
     100
     101      do j = 1 to n;
     102          nam = val(org+j);
     103          is_avail(nam) = yes;
     104
     105          countup(proctabp, proctab_lim, 'proctab');
     106          proctab(proctabp) = nam;
     107      end do;
     108
     109
     110      end subr sethd;
       1 .=member ggsym1
       2      subr ggsym1;
       3
       4$ this routine is called before seeing the first declaration in a
       5$ .  we save a pointer to the zero'th global variable so
       6$ that we can later process 'reads all' and 'writes all'.
       7
       8
       9      gsym_org = symtabp;
      10
      11
      12      end subr ggsym1;
       1 .=member ggsym2
       2      subr ggsym2;
       3
       4$ this routine is called after the last global declaration. we
       5$ save a pointer to the last global variable.
       6
       7
       8      gsymp = symtabp;
       9
      10
      11      end subr ggsym2;
       1 .=member gpdcl1
       2      subr gpdcl1;
       3
       4$ this routine declares procedures with a variable number of
       5$ arguments.
       6
       7
       8      size n(ps);   $ number of arguments-1
       9
      10
      11      pop1(n);
      12      call prcdcl(n+1, yes);
      13
      14
      15      end subr gpdcl1;
       1 .=member gpdcl2
       2      subr gpdcl2;
       3
       4$ this routine declares procdeures with a fixed number of arguments
       5
       6
       7      size n(ps);  $ number of arguments-1
       8
       9
      10      pop1(n);
      11      call prcdcl(n+1, no);
      12
      13
      14      end subr gpdcl2;
       1 .=member gpdcl3
       2      subr gpdcl3;
       3
       4$ this routine declares procedures with 0 arguments.
       5
       6      call prcdcl(0, no);
       7
       8
       9      end subr gpdcl3;
       1 .=member gpdcl4
       2      subr gpdcl4;
       3
       4$ this routine provides the default mode for a parameter.
       5
       6      push1(sym_rd);
       7
       8
       9      end subr gpdcl4;
       1 .=member gpdcl5
       2      subr gpdcl5;
       3
       4$ this routine declares a procedure with 1 argument.
       5
       6      call prcdcl(1, no);
       7
       8
       9      end subr gpdcl5;
       1 .=member gpdcl6
       2      subr gpdcl6;
       3
       4$ this routine declares a procedure with 2 arguments.
       5
       6      call prcdcl(2, no);
       7
       8
       9      end subr gpdcl6;
       1 .=member gpdcl7
       2      subr gpdcl7;
       3
       4$ this routine is called after we have processed a procedure
       5$ declaration at the beginning of a member. we must do two things:
       6
       7$ 1. pop the procedure name from astack.
       8
       9$ 2. enter it in proctab if it is not already there.
      10
      11      size rout(ps),     $ routine name
      12           j(ps);        $ loop index
      13
      14      pop1(rout);
      15
      16      do j = 1 to proctabp;
      17          if (rout = proctab(j)) return;
      18      end do;
      19
      20      countup(proctabp, proctab_lim, 'proctab');
      21      proctab(proctabp) = rout;
      22
      23
      24      end subr gpdcl7;
       1 .=member prcdcl
       2      subr prcdcl(n, vary);
       3
       4$ this routine 'declares' a procedure with n arguments. 'vary' is
       5$ true if the routine has a variable number of arguments.
       6
       7$ on entry astack contains 'n' keywords such as '.rd' or '.rw'
       8$ followed by the routine name. we build the routines symbol table
       9$ entry then pop the keywords, leaving the routine name on the top
      10$ of the stack.
      11
      12$ each procedure has a global variable associated with it which is
      13$ used to store the result of the procedure. the name of this variable
smfb 124$ is stored in the procedure's val entry.
      15
      16$ the procedure itself recieves storage. this is done so that we
      17$ will be able to get to the procedure name at run time.
      18
smfb 125      size n(ps);             $ number of args (vary = yes: min no.)
smfb 126      size vary(1);           $ variable number of arguments
      21
smfb 127      size rout(ps);          $ symtab pointer for routine name
smfb 128      size ret(ps);           $ symtab pointer for its return value
smfb 129      size vp(ps);            $ routine's val pointer
smfb 130      size j(ps);             $ loop index
      25
      26
      27      rout = astack(asp-n);
      28
      29      if is_decl(rout) then  $ duplicate declaration, check consistency
      30
      31          if ( ^ is_proc(rout)) call ermsg(95, rout);
      32
      33          vp = vptr(rout);
      34
      35          if (val(vp+1) ^= vary) call ermsg(64, rout);
      36          if (val(vp+2) ^= n)    call ermsg(64, rout);
      37
      38          do j = 1 to n;
      39              if (val(vp+2+j) ^= astack(asp-n+j)) call ermsg(64, rout);
      40          end do;
      41
      42      else  $ process new declaration
      43          is_decl(rout)  = yes;
      44          is_rec(rout)   = yes;
      45          is_avail(rout) = yes;
      46          is_store(rout) = yes;
      47
      48          form(rout) = f_proc;
      49
smfb 131          $ get the symbol table pointer for the return value
smfb 132          ret = hashst( symsds(rout) .cc. '(..)' );
smfb 133          is_stk(ret)  = yes;   is_store(ret) = yes;
smfb 134          is_read(ret) = yes;   is_write(ret) = yes;
smfb 135
smfb 136          $ build the val entry for rout
      50          vptr(rout) = valp + 1;
      51          vlen(rout) = n + 3;
      52
      53          valp = valp + n + 3;
      54          if (valp > val_lim) call overfl('val');
      55
      56          vp = vptr(rout);
      57
smfb 137          val(vp)   = ret;
      59          val(vp+1) = vary;
      60          val(vp+2) = n;
      61
      62          do j = 1 to n;   $ copy argument modes into val.
      63              val(vp+2+j) = astack(asp-n+j);
      64          end do;
      65      end if;
      66
      67      free_stack(n);
      68
      69
      70      end subr prcdcl;
       1 .=member gendm
       2      subr gendm;
       3
       4$ this routine is called at the end of each member. it checks that
       5$ there are no missing procedures
       6
       7
       8      size j(ps),  $ loop index
       9           proc(ps); $ procedure name
      10
      11      size org(ps),    $ origin for members val entry
      12           n(ps);      $ length of rights list
      13
      14      size isfbsd(1);         $ true if type is based
      15
      16
      17$ check procedures
      18      do j = 1 to proctabp;
      19          proc = proctab(j);
      20          if (^ is_decl(proc)) call ermsg(40, proc);
      21      end do;
      22
      23$ if this is a library, check that none of the exported procedures
      24$ have based reprs.
      25
      26
      27      if unit_type ^= unit_lib then
      28          curmemb = curdir;
      29          return;
      30      end if;
      31
      32      org = vptr(curmemb);   $ start of val entry
      33      n   = val(org);
      34
      35$ find first exported procedure
      36      do j = 1 to 4;
      37          org = org+n+1;
      38          n   = val(org);
      39      end do;
      40
      41      do j = 1 to n;
      42          proc = val(org+j);
      43          if (isfbsd(form(proc))) call ermsg(78, proc);
      44      end do;
      45
      46
      47      end subr gendm;
       1 .=member gmprog
       2      subr gmprog;
       3
       4$ this routine is called at the start of the main program.
       5$ a main program is treated as a subroutine with a reserved
       6$ name.
       7
       8      push1(sym_main_);
       9      call gdef1;
      10      call gdef3;
      11
      12      $ pretend that we have seen 'program s$main;', i.e. emit
      13      $ a statement quadruple and reset estmt_count.
      14      call emit(q1_stmt, 0, 0, 0);
      15      estmt_count = estmt_count - 1;
      16
      17
      18      end subr gmprog;
       1 .=member gcnst1
       2      subr gcnst1;
       3
       4$ this routine processes the statement 'const a = b'.
       5
       6$ we treat each symbolic constant as an alias for a unique internally
       7$ generated constant. this is done in order to avoid forward
       8$ references from a symbol table entry with is_store = yes to
       9$ its value. such forward references cause problems during
      10$ code generation.
      11
      12
      13      size a(ps),  $ symbol table pointers
      14           b(ps);
      15      size i(ps);             $ loop index
      16
      17      size temp(ps);  $ internal variable
      18
      19
      20      pop2(b, a);
      21
      22      if (^ is_store(b)) b = alias(b);
      23
      24      if is_decl(a) then
      25          if is_memb(a) ! is_proc(a) then
      26              call ermsg(2, a);
      27          else
      28              call ermsg(5, a);
      29          end if;
      30
      31      elseif ^ is_local(a) then
      32          call ermsg(39, a);
      33
      34      else
      35
      36$ allocate an internal variable. note that if 'a' is global we
      37$ must allocate a variable whose name depends on 'a'.
      38
      39          if b ^= sym_om then
      40
      41              if unit_type = unit_proc then $ local
      42                  temp = getvar(0);
      43              else
      44                  temp = getglb(a);
      45              end if unit_type;
      46
      47              form(temp) = form(b);
      48              is_decl(temp) = yes;
      49
bnda  15              $ copy the val entry, so that is is local to the current
bnda  16              $ scope.
bnda  17
bnda  18              vptr(temp) = valp + 1;
bnda  19
bnda  20              do i = 0 to vlen(b) - 1;
bnda  21                  countup(valp, val_lim, 'val');
bnda  22                  val(valp) = val(vptr(b) + i);
bnda  23              end do;
bnda  24
      64              vlen(temp) = vlen(b);
      65
      66              is_repr(temp)  = yes;
      67              is_store(temp) = yes;
      68              is_write(temp) = no;
      69              is_stk(temp)   = no;
      70
      71          else
      72              temp = sym_om;
      73          end if b;
      74
      75          is_decl(a) = yes;
      76          is_read(a) = yes;
      77          is_repr(a) = yes;
      78          is_store(a) = no;
      79
      80          alias(a) = temp;
      81
      82$ set the fields of 'a' to match those of 'temp' so that macros like
      83$ symtype and symval work properly.
      84          vptr(a)  = vptr(temp);
      85          vlen(a)  = vlen(temp);
      86          form(a)  = form(temp);
      87      end if;
      88
      89
      90      end subr gcnst1;
       1 .=member gcnst2
       2      subr gcnst2;
       3
       4$ this routine processes the statement 'const nam;'.  we treat it
       5$ as a short form for 'const nam = 'nam';'.
       6
       7
       8      size nam(ps);           $ name of identifier
       9      size str(ps);           $ symtab pointer for string
      10
      11
      12      nam = astack(asp);
      13      str = hashst(1q' .cc. symsds(nam) .cc. 1q');
      14
      15      push1(str);   call gstr;   call gcnst1;
      16
      17
      18      end subr gcnst2;
       1 .=member gvar
       2      subr gvar;
       3
       4$ this routine is called after seeing a complete 'var' declaration.
       5$ we pop a series of names and set their storage options.
       6
       7
       8      size n(ps),   $ number of variables-1
       9           j(ps),  $ loop index
      10           var(ps); $ name of variable
      11
      12
      13      pop1(n);   $ number of names-1
      14
      15      do j = 1 to n+1;
      16          pop1(var);
      17
      18          if is_param(var) then  $ set 'back' option
      19              is_back(var) = bk_flag;
      20
      21          elseif is_decl(var) then
      22              if is_memb(var) ! is_proc(var) then
      23                  call ermsg(2, var);
      24              else
      25                  call ermsg(5, var);
      26              end if;
      27
      28          elseif ^ is_local(var) then $ wrong scope
      29              call ermsg(39, var);
      30
      31          else
      32              is_decl(var)  = yes;
      33              is_read(var)  = yes;
      34              is_write(var) = yes;
      35              is_store(var) = yes;
      36              is_back(var)  = bk_flag;
      37
      38              if unit_type = unit_proc & currout ^= sym_main_ then
      39                  is_stk(var) = yes;
      40              else
      41                  is_stk(var) = no;
      42              end if;
      43          end if;
      44      end do;
      45
      46
      47      end subr gvar;
       1 .=member gbk
       2      subr gbk;
       3
       4$ this routine is called after seeing the keyword 'back' in a var
       5$ statement.
       6
       7      bk_flag = yes;
       8
       9
      10      end subr gbk;
       1 .=member gnobk
       2      subr gnobk;
       3
       4$ this routine is called after seeing a var statement without a
       5$ 'back' option.
       6
       7      bk_flag = no;
       8
       9
      10      end subr gnobk;
       1 .=member ginit
       2      subr ginit;
       3
       4$ this routine processes the 'init' statement. the semantics of
       5$ the 'init' statement depend on whether the variable being
       6$ initialized is global or local.
       7
       8$ global variables are static, and are initialized once at
       9$ compile time. we do this by adjusting the symtab entry for
      10$ the variable so that it is just like the entry for a
      11$ symbolic constant, but has its is_write flag set. see
      12$ -gcnst1- for details.
      13
      14$ local variables are stacked, and are initialized each time
      15$ their routine is entered. this is done simply by emitting the
      16$ proper assignment.
      17
      18      size var(ps),       $ program variable
      19           temp(ps),      $ internal variable
      20           vl(ps);        $ value
      21      size i(ps);             $ loop index
      22
      23      pop2(vl, var);
      24
      25      if ^ is_local(var) then
      26          call ermsg(48, var);
      27
      28      elseif is_const(var) ! is_param(var) then
      29          call ermsg(76, var);
      30
      31      elseif unit_type = unit_proc then  $ local variable
      32          call emit(q1_asn, var, vl, 0);
      33
      34      else                               $ global variable
      35
      36          temp = getglb(var);
      37
      38          is_decl(temp) = yes;
      39          is_repr(temp) = yes;
      40          is_stk(temp)  = yes;
      41          form(temp)    = form(vl);
      42
bnda  25          $ copy the val entry, so that is is local to the current
bnda  26          $ scope.
bnda  27
bnda  28          vptr(temp) = valp + 1;
bnda  29
bnda  30          do i = 0 to vlen(vl) - 1;
bnda  31              countup(valp, val_lim, 'val');
bnda  32              val(valp) = val(vptr(vl) + i);
bnda  33          end do;
bnda  34
      57          vlen(temp)   = vlen(vl);
      58
      59          is_init(var)  = yes;
      60          is_store(var) = no;
      61          alias(var)    = temp;
      62      end if;
      63
      64
      65      end subr ginit;
       1 .=member grepr
       2      subr grepr;
       3
       4$ this routine processes the repr statement. we iterate over the list
       5$ of names, setting their forms. we call a separate routine to
       6$ process local objects.
       7
       8
       9      size fm(ps);            $ form of object to be repr'ed
      10      size tp(ps),   $ type descriptor
      11           n(ps),      $ no. of variables-1
      12           j(ps),      $ loop index
      13           nam(ps);    $ variable name
      14
      15
      16      pop2(fm, n);
      17
      18      do j = 1 to n+1;
      19          pop1(nam);
      20
      21          if (is_floc(fm)) call useloc(fm);   $ get unique form
      22
      23          if ^ is_local(nam) then
      24              call ermsg(6, nam);
      25
smfb 138          elseif rpr_flag = 0 then
      27              cont;
      28
      29          elseif is_proc(nam) then
      30              call rproc(nam, fm);
      31
      32          elseif is_const(nam) then
      33              call rconst(nam, fm);
      34
      35          elseif is_init(nam) then  $ initialised variable
      36              call rinit(nam, fm);
      37
      38          elseif is_repr(nam) then
      39              if is_fset(fm) then
      40                  if (^ same_repr(fm, form(nam))) call ermsg(9, nam);
      41              else
      42                  if (fm ^= form(nam)) call ermsg(9, nam);
      43              end if;
      44
      45          elseif is_param(nam) then
      46              if is_fset(fm) then
      47                  if ( ^ same_repr(fm, form(nam))) call ermsg(15, 0);
      48              else
      49                  if (fm ^= form(nam)) call ermsg(15, 0);
      50              end if;
      51
      52          else     $ variable
      53
      54$ see if the variable has been declared in a 'var' statement.
      55$ if not there are possibilities:
      56
      57$ 1. we are compiling a procedure. then the occurrence of 'nam' is
      58$    an explicit declaration.
      59
      60$ 2. otherwise the repr is changing the scope of nam, which is an
      61$    error.
      62
      63              if ^ is_decl(nam) then
      64                  if unit_type = unit_proc then
      65                      call chkvar(nam);
      66                  else
      67                      call ermsg(61, nam);
      68                  end if;
      69              end if;
      70
      71              $ if this is a plex form, we should not have come here,
      72              $ since we require all plex forms to be initialised by
      73              $ an init statement.
      74              if (is_fplex(fm)) call ermsg(88, nam);
      75
      76              $ we only allow based smaps to have untyped ranges: check
      77              if is_fmap(fm) then
      78                  if ^ is_fbsd(fm) & is_funt(ft_im(fm)) then
      79                      call ermsg(74, nam);
      80                  end if;
      81              end if;
      82              tp = ft_type(fm);
      83
      84              if tp = f_proc ! tp = f_memb ! tp = f_lab then
      85                  call ermsg(81, nam);
      86              end if;
      87
      88$ emit a warning if a stacked or backtracked variable is given
      89$ a local repr.
      90              if is_floc(fm) then
      91                  if (is_stk(nam))  call warn(1, nam);
      92                  if (is_back(nam)) call warn(2, nam);
      93              end if;
      94
      95              is_repr(nam) = yes;
      96              form(nam)    = fm;
      97          end if;
      98      end do;
      99
     100
     101      end subr grepr;
       1 .=member rconst
       2      subr rconst(nam, fm);
       3
       4$ this routine processes reprs for symbolic constants.  each
       5$ symbolic constant is an alias for a unique internally generated
       6$ constant.
       7
       8$ reprs for constants are processed in four steps:
       9$
      10$ 1. set 'xfm' to the original type of the constant. if fm = xfm
      11$    return.
      12$
      13$ 2. otherwise if fm and xfm are compatible, i.e. both sets, set
      14$    the forms for the symbolic constant and the internal constant
      15$    to 'fm'.
      16$
      17$ 3. otherwise if 'fm' is type element then build a new symtab
      18$    entry with the proper type and value and set alias(nam) to
      19$    point to it.
      20$
      21$ 4. otherwise the types are inconsistemt, and we issue an error
      22$    message.
      23
      24$ for now we do a 1 level check for type consistency.  the code
      25$ generator does a full check later on.
      26
      27
      28      size nam(ps);           $ name of symbolic constant
      29      size fm(ps);            $ desired type
      30
      31      size xfm(ps);           $ original form of constant
      32      size elmt(ps);          $ new entry of type element
      33
      34      size genelt(ps);        $ builds element
      35
      36
      37      is_repr(nam) = yes;
      38
      39      xfm = form(nam);
      40
      41      if fm = xfm then
      42          return;
      43
      44      elseif (is_fint(fm) & is_fint(xfm))   !   $ two integers
      45             (is_freal(fm) & is_freal(xfm)) !   $ two reals
      46             (is_fset(fm) & is_fset(xfm))   !   $ two sets
      47             (is_ftup(fm) & is_ftup(xfm)) then  $ two tuples
      48
      49          form(alias(nam)) = fm;
      50          form(nam)        = fm;
      51
      52      elseif ft_type(fm) = f_elmt then  $ make new entry
      53          elmt = genelt(nam, fm);
      54
      55          alias(nam) = elmt;
      56          form(nam)  = fm;
      57          vptr(nam)  = vptr(elmt);
      58          vlen(nam)  = vlen(elmt);
      59
      60
      61      else
      62          call ermsg(22, nam);
      63      end if;
      64
      65
      66
      67      end subr rconst;
       1 .=member rinit
       2      subr rinit(nam, fm);
       3
       4$ this routine is similar to rconst, but processes variables
       5$ which hanve already been initialized. we check that the repr is
       6$ consistent with the repr of the initial value.
       7
       8      size nam(ps);           $ name of initialised variable
       9      size fm(ps);            $ desired type
      10
      11      size xfm(ps);           $ form of initialised variable's value
      12
      13      size genelt(ps);        $ builds element
      14
      15
      16      is_repr(nam) = yes;
      17
      18      xfm = form(alias(nam));
      19
      20      if fm = xfm then
      21          form(nam) = fm;
      22          return;
      23
      24      elseif (is_fint(fm) & is_fint(xfm))   !          $ two ints
      25             (is_freal(fm) & is_freal(xfm)) !          $ two reals
      26             (is_fset(fm) & is_fset(xfm))   !          $ two sets
      27             (is_ftup(fm) & is_ftup(xfm)) then  $ two tuples
      28
      29          form(alias(nam)) = fm;
      30          form(nam)        = fm;
      31
      32      elseif ft_type(fm) = f_elmt then  $ make new entry
      33          alias(nam) = genelt(nam, fm);
      34          form(nam)  = fm;
      35
      36      else
      37          call ermsg(22, nam);
      38      end if;
      39
      40
      41      end subr rinit;
       1 .=member rproc
       2      subr rproc(nam, tp);
       3
       4$ this routine tries to give the repr 'tp' to a procedure 'nam'.
       5
       6      size nam(ps),  $ procedure name
       7           tp(ps);   $ its type
       8
       9      size ret(ps);  $ name of variable for procedure result
      10
      11      size fm(ps),  $ form of procedure
      12           na(ps);  $ its number of arguments
      13
      14      size loc(1);  $ see below
      15
      16$ before we assign a type to a procedure we check whether
      17$ the types of any of its arguments or of its returned value
      18$ are 'local set' or 'local map'. if so then we generate a
      19$ unique formtab entry with unique argument types. this
      20$ is done by calling 'ulcprc'.
      21
      22$ the flag 'loc' is set to indicate whether there are local
      23$ argument types. if so, we must issue a warning.
      24
      25      is_repr(nam) = yes;
      26
      27      fm = form(nam);
      28      na = val(vptr(nam)+2);
      29
      30      if tp = f_proc then
      31          ret = symval(nam);  $ declare the return value
      32          form(ret)    = f_gen;
      33          is_repr(ret) = yes;
      34
      35          return;
      36
      37      elseif fm = f_proc & ft_type(tp) = f_proc & na = ft_lim(tp)-1 then
      38
      39          call ulcprc(tp, loc);
      40          if (loc) call warn(1, nam);
      41
      42          form(nam) = tp;
      43
      44          ret = symval(nam);   $ type result
      45
      46          is_repr(ret) = yes;
      47          form(ret)    = mttab(ft_elmt(tp) + ft_lim(tp));
      48
      49      else
      50          call ermsg(67, nam);
      51      end if;
      52
      53
      54      end subr rproc;
       1 .=member useloc
       2      subr useloc(fm);
       3
       4$ this routine is called whenever a local type is used in a repr
       5$ statement. we reset fm to point to a new formtab entry with a
       6$ unique ft_pos and increment the ft_num field of the base.
       7
       8      size fm(ps);  $ form
       9
      10      size tp(ps),  $ ft_type
      11           base(ps); $ form of base
      12
      13      countup(formtabp, formtab_lim, 'formtab');
      14      formtab(formtabp) = formtab(fm);
smfa  14      ft_link(formtabp) = 0;   ft_deref(formtabp) = formtabp;
      16
      17      fm = formtabp;
      18
      19      tp = ft_type(fm);
      20      base = ft_base(fm);
      21
      22      countup(ft_num(base, tp), ft_num_max, 'ft_num');
      23      ft_pos(fm) = ft_num(base, tp);
      24
      25$ all local objects based on 'base' must be repred in the same
      26$ scope as 'base'.
      27      if (^ is_local_repr(base)) call ermsg(69, 0);
      28
      29
      30      end subr useloc;
       1 .=member ulcprc
       2      subr ulcprc(tp, loc);
       3
       4$ this routine is called before assigning a type to a procedure.
       5$ we check whether any of the argument types of the procedure are
       6$ local. if so we generate a new formtab entry.
       7
       8      size tp(ps),   $ procedure type
       9           loc(1);   $ set to yes if there are local args
      10
      11      size n(ps),   $ number of arguments
      12           j(ps),  $ loop index
      13           tp1(ps);  $ argument type
      14
      15      n   = ft_lim(tp);
      16      loc = no;
      17
      18      do j = 1 to n;
      19          tp1 = mttab(ft_elmt(tp)+j);
      20
      21          if is_floc(tp1) then
      22              loc = yes;
      23              call useloc(tp1);
      24          end if;
      25
      26          push1(tp1);
      27      end do;
      28
      29      if loc then
      30          push1(n-1);   call gtprc1;   pop1(tp);
      31      else
      32          free_stack(n);
      33      end if;
      34
      35
      36      end subr ulcprc;
       1 .=member gmode
       2      subr gmode;
       3
       4$ this routine processes mode declarations.
       5
       6
       7      size nam(ps),  $ mode name
       8           type(ps); $ its type
       9
      10
      11      pop2(type, nam);  $ pop type and mode nam.
      12
      13      if is_decl(nam) then
      14          call ermsg(8, nam);
      15      else
      16          is_decl(nam) = yes;
      17          is_repr(nam) = yes;
      18          is_mode(nam) = yes;
      19          form(nam) = type;
      20      end if;
      21
      22
      23      end subr gmode;
       1 .=member gbase1
       2      subr gbase1;
       3
       4$ this routine processes 'base b1 ... bn: type'. we generate a unique
       5$ formtab entry for each base.
       6
       7$ notice that constant base names are always treated as an alias for
       8$ an internally generated constant.
       9$
      10$ we first generate a new formtab entry for 'base()'.  new
      11$ formtab entries, or mode descriptors, are built in two steps:
      12$
      13$ 1. increment formtabp and build the new entry at formtab(formtabp).
      14$
      15$ 2. search formtab for an earlier entry which matches the new one.
      16$    if there is an earlier entry, we erase the new entry and
      17$    return the old one; otherwise we return the new entry.
      18$
      19$    formtab is searched by two routines: hashf1 handles one word
      20$    forms and hashf2 handles forms which use mttab.
      21
      22
      23      size base(ps);          $ base name
      24      size elmt(ps);          $ form of base elements
      25      size fm(ps);            $ form of base
      26      size n(ps);             $ number of bases - 1
      27      size j(ps);             $ loop index
      28
      29
      30      pop2(elmt, n);
      31
      32      if (is_funt(elmt) ! is_floc(elmt)) call ermsg(71, 0);
      33
      34      countup(formtabp, formtab_lim, 'formtab');
      35      formtab(formtabp) = 0;
      36      ft_type(formtabp) = f_base;
      37      ft_elmt(formtabp) = elmt;
      38
      39      fm = hashf1(0);
      40
      41      do j = 1 to n+1;
      42          pop1(base);
      43
      44          if is_decl(base) & ^ is_const(base) then
      45              call ermsg(4, base);
      46
      47          else
      48
      49              if (alias(base) ^= 0) base = alias(base);
      50
      51              is_decl(base)  = yes;
      52              is_repr(base)  = yes;
      53              is_store(base) = yes;
      54
      55$ generate a new formtab entry for each base
      56              countup(formtabp, formtab_lim, 'formtab');
      57              formtab(formtabp) = formtab(fm);
smfa  15              ft_link(formtabp) = 0;   ft_deref(formtabp) = formtabp;
      58
      59              if (is_const(base)) ft_lim(formtabp) = vlen(base);
      60
      61              form(base) = formtabp;
      62          end if;
      63
      64      end do;
      65
      66
      67      end subr gbase1;
       1 .=member gbase2
       2      subr gbase2;
       3
       4$ this routine processes 'base b1 ... bn;'. we push the formtab
       5$ pointer for general then call 'gbase1'.
       6
       7      push1(f_gen);
       8      call gbase1;
       9
      10
      11      end subr gbase2;
       1 .=member gplex
       2      subr gplex;
       3
       4$ this routine processes the 'plex base' statement. it is similar
       5$ to gbase1.
       6
       7
       8      size n(ps),     $ number of bases-1
       9           j(ps),     $ loop index
      10           base(ps);  $ base name
      11
      12
      13
      14      pop1(n);
      15
      16      do j = 1 to n+1;
      17          pop1(base);
      18
      19          if is_decl(base) then
      20              call ermsg(4, base);
      21
      22          else
      23              is_decl(base)  = yes;
      24              is_repr(base)  = yes;
      25              is_store(base) = yes;
      26
      27$ generate a new formtab entry for each base
      28              countup(formtabp, formtab_lim, 'formtab');
      29              formtab(formtabp) = 0;
      30              ft_type(formtabp) = f_pbase;
      31
      32              form(base)        = formtabp;
      33          end if;
      34
      35      end do;
      36
      37
      38      end subr gplex;
       1 .=member gtpref
       2      subr gtpref;
       3
       4$ this routine processes mode descriptors of the form ' ',
       5$ where  is 'local', 'untyped', etc.
       6$
       7$ we begin by popping the original mode and the prefix.  we
       8$ then determine the new mode and jump on the prefix.
       9
      10
      11      size prefix(ps);        $ name of prefix
      12      size type(ps);          $ original type
      13      size ntype(ps);         $ new ft_type
      14      size etype(ps);         $ element type
      15      size itype(ps);         $ image type
      16      size ptype(ps);         $ packed type
      17      size ttype(ps);         $ type of embedded tuple for remote maps
      18
      19      size mx(ps);            $ maximum value stored in packed object
      20
      21
      22      pop2(type, prefix);
      23
      24      ntype = prefix_map(prefix, ft_type(type));
      25
      26      go to case(prefix) in sym_local to sym_untyped;
      27
      28/case(sym_local)/     $ local set or map
      29
      30/case(sym_remote)/
      31
      32$ set etype and ttype, then check etype for validity
      33      if is_fmap(type) then
      34          etype = ft_dom(type);
      35
      36          if prefix = sym_remote then
      37              itype = ft_im(type);
      38
      39              $ get the form for the embedded tuple
      40              if (is_floc(itype)) call ermsg(72, 0);
      41
      42              countup(formtabp, formtab_lim, 'formtab');
      43              formtab(formtabp) = 0;
      44              ft_type(formtabp) = tuple_type(itype);
      45              ft_elmt(formtabp) = itype;
      46
      47              ttype = hashf1(0);
      48
      49          else
      50              ttype = 0;
      51          end if;
      52
      53      elseif is_fset(type) then
      54          etype = ft_elmt(type);
      55          ttype = 0;
      56
      57      else
      58          go to error;
      59      end if;
      60
      61      if (ft_type(etype) ^= f_elmt) go to error;
      62      if prefix = sym_remote then
      63          if (ft_type(ft_base(etype)) = f_pbase) call ermsg(70, 0);
      64      end if;
      65
      66$ build new formtab entry
      67      countup(formtabp, formtab_lim, 'formtab');
      68
      69      formtab(formtabp) = formtab(type);
      70      ft_link(formtabp) = 0;
bnda  35      ft_deref(formtabp) = 0;
      71
      72      ft_type(formtabp) = ntype;
      73      ft_base(formtabp) = ft_base(etype);
      74      ft_tup(formtabp)  = ttype;
      75
      76      go to esac;
      77
      78/case(sym_sparse)/
      79
      80      if is_fmap(type) then
      81          etype = ft_dom(type);
      82
      83      elseif is_fset(type) then
      84          etype = ft_elmt(type);
      85
      86      else
      87          go to error;
      88      end if;
      89
      90      if (ft_type(etype) ^= f_elmt) go to error;
      91
      92$ since 'sparse set(_ b)' and 'set(_ b)' are really the same type
      93$ we merely push the original formtab pointer and return.
      94
      95      push1(type);
      96      return;
      97
      98
      99/case(sym_packed)/
     100
     101$ find type being packed
     102
     103      if ft_type(type) = f_tuple then
     104          ptype = ft_elmt(type);
     105
     106      elseif ft_type(type) = f_rmap ! ft_type(type) = f_lmap then
     107          if (ft_mapc(type) = ft_mmap) go to error;
     108          ptype = ft_im(type);
     109
     110      else
     111          go to error;
     112      end if;
     113
     114$ check that ptype is valid
     115
     116      if (ft_type(ptype) = f_sint)    go to pass;   $ short integer
     117
     118      if (ft_type(ptype) ^= f_elmt)   go to error;    $ not element
     119      if (ft_lim(ft_base(ptype)) = 0) go to error;    $ not const
     120
     121/pass/       $ valid packed type
     122
     123$ if the packed value takes more than ws/2 bits and this is not
     124$ a local map, ignore the repr.
     125$
     126$ nb. implementation restriction:  the range integer 0 .. n can
     127$ not be packed, since the pack key stores (i-1) for the range
     128$ integer i .. j.
     129$
     130      if ft_type(ptype) = f_elmt then
     131          mx = ft_lim(ft_base(ptype));
     132      else
     133          mx = ft_lim(ptype);
     134          if (ft_low(ptype) = 0) call ermsg(85, 0);
     135      end if;
     136
     137      if .fb. mx > ws/2 & ntype ^= f_lpmap then
     138          push1(type);
     139          return;
     140      end if;
     141
     142$ if we are building a packed remote map we must compute build
     143$ a new formtab entry for its embedded tuple.
     144
     145      if ntype = f_rpmap then
     146          countup(formtabp, formtab_lim, 'formtab');
     147
     148          formtab(formtabp) = formtab(ft_tup(type));
     149          ft_link(formtabp) = 0;
bnda  36          ft_deref(formtabp) = 0;
     150
     151          ft_type(formtabp) = f_ptuple;
     152
     153          ttype = hashf1(0);
     154
     155      else   $ ft_tup unused
     156          ttype = 0;
     157      end if;
     158
     159      countup(formtabp, formtab_lim, 'formtab');
     160
     161      formtab(formtabp) = formtab(type);
     162      ft_link(formtabp) = 0;
bnda  37      ft_deref(formtabp) = 0;
     163
     164      ft_type(formtabp) = ntype;
     165      ft_tup(formtabp)  = ttype;
     166
     167      go to esac;
     168
     169
     170/case(sym_untyped)/
     171
     172      if (^ is_fnum(type)) go to error;
     173
     174$ 'ntype' gives the new type. push it and return.
     175      push1(ntype);
     176      return;
     177
     178/esac/
     179
     180      push1(hashf1(0));
     181
     182      return;
     183
     184/error/
     185
     186      call ermsg(12, prefix);
     187      push1(f_gen);
     188
     189      return;
     190
     191      end subr gtpref;
       1 .=member gtmode
       2      subr gtmode;
       3
       4$ this routine processes a mode name when it is used as a type.
       5
       6
       7      size nam(ps);  $ mode name
       8
       9
      10      pop1(nam);
      11
      12      if is_mode(nam) then
      13          push1(form(nam));
      14      else
      15          call ermsg(10, nam);
      16          push1(f_gen);
      17      end if;
      18
      19
      20      end subr gtmode;
       1 .=member gtgen
       2      subr gtgen;
       3
       4$ this routine processes the mode '*'.
       5
       6      push1(f_gen);
       7
       8      end subr gtgen;
       1 .=member gtint
       2      subr gtint;
       3
       4$ this routine processes the mode 'integer lo ... hi'.
       5
       6      size mode(ps);          $ mode keyword 'integer'
       7      size lo(ps);            $ lower bound of range
       8      size hi(ps);            $ upper bound of range
       9
      10
      11      pop3(hi, lo, mode);
      12
      13      if symtype(lo) ^= f_sint then
      14          call ermsg(14, lo);   push1(f_int);
      15
      16      elseif symtype(hi) ^= f_sint then
      17          call ermsg(14, hi);   push1(f_int);
      18
      19      elseif symval(lo) > symval(hi) then
bnda  38          call ermsg(99, 0);    push1(f_int);
      21
      22      elseif symval(hi) > ft_lim_max then
      23          push1(f_sint);
      24
      25      else
      26          countup(formtabp, formtab_lim, 'formtab');
      27          formtab(formtabp)    = 0;
      28          ft_type(formtabp)    = f_sint;
      29          ft_low(formtabp)     = symval(lo);
      30          ft_lim(formtabp)     = symval(hi);
      31
      32          if (symval(lo) > ft_low_max) ft_low(formtabp) = ft_low_max;
      33
      34          push1(hashf1(0));
      35      end if;
      36
      37
      38      end subr gtint;
       1 .=member gtprim
       2      subr gtprim;
       3
       4$ this routine processes modes consisting only of a mode keyword.
       5$
       6$ rather than popping the mode keyword from the stack, and pushing
       7$ the proper form onto the stack, we map the top astack entry directly.
       8
       9      astack(asp) = mode_map(astack(asp));
      10
      11      end subr gtprim;
       1 .=member gtelmt
       2      subr gtelmt;
       3
       4$ this routine processes 'elmt base'.
       5$
       6$ notice that constant base names are always treated as an alias for
       7$ an internally generated constant.
       8
       9
      10      size base(ps);          $ base name
      11
      12
      13      pop1(base);   if (alias(base) ^= 0) base = alias(base);
      14
      15      if is_base(base) then   $ valid base name
      16          countup(formtabp, formtab_lim, 'formtab');
      17          formtab(formtabp) = 0;
      18          ft_type(formtabp) = f_elmt;
      19          ft_base(formtabp) = form(base);
      20
      21          push1(hashf1(0));
      22
      23      else
      24          call ermsg(11, base);   push1(f_elmt);
      25      end if;
      26
      27
      28      end subr gtelmt;
       1 .=member gttup1
       2      subr gttup1;
       3
       4$ this routine processes type decsriptors for mixed tuples.
       5$ the top astack entry is the number of modes - 2.
       6$
       7$ yes, we do mean - 2.
       8
       9
      10      size elmt(ps);          $ mode of element
      11      size n(ps);             $ number of elements - 2
      12      size j(ps);             $ loop index
      13
      14
      15      pop1(n);
      16
      17      countup(formtabp, formtab_lim, 'formtab');
      18      formtab(formtabp)   = 0;
      19      ft_type(formtabp)   = f_mtuple;
      20      ft_elmt(formtabp)   = mttabp;
      21      ft_lim(formtabp)    = n + 2;
      22      ft_neltok(formtabp) = yes;
      23
      24      $ enter elements in mttab
      25      do j = n+1 to 0 by -1;
      26          elmt = astack(asp-j);
      27
      28          if (is_funt(elmt) ! is_floc(elmt)) call ermsg(75, 0);
      29
      30          countup(mttabp, mttab_lim, 'mttab');
      31          mttab(mttabp) = elmt;
      32      end do;
      33
      34      free_stack(n+2);
      35
      36      push1(hashf2(0));
      37
      38
      39      end subr gttup1;
       1 .=member gttup2
       2      subr gttup2;
       3
       4$ this routine processes homogeneous tuple where the average
       5$ length of the tuple is given.
       6
       7
       8      size elmt(ps);          $ mode of tuple elements
       9      size lim(ps);           $ length of tuple
      10
      11
      12      pop2(lim, elmt);
      13
      14      if (^is_const(lim) ! form(lim)^=f_sint) call ermsg(14, lim);
      15
      16      if (is_floc(elmt)) call ermsg(72, 0);
      17
      18      countup(formtabp, formtab_lim, 'formtab');
      19      formtab(formtabp)   = 0;
      20      ft_type(formtabp)   = tuple_type(elmt);
      21      ft_elmt(formtabp)   = elmt;
      22      ft_neltok(formtabp) = yes;
      23
      24      if (symval(lim) < ft_lim_max) ft_lim(formtabp) = symval(lim);
      25
      26      push1(hashf1(0));
      27
      28
      29      end subr gttup2;
       1 .=member gttup3
       2      subr gttup3;
       3
       4$ this routine processes homogeneous tuples where no range is given
       5$ treat it as if it had a range of 0.
       6
       7      push1(sym_zero);   call gttup2;
       8
       9
      10      end subr gttup3;
       1 .=member gtset
       2      subr gtset;
       3
       4$ this routine processes the mode 'set(  )'.  it builds a
       5$ formtab entry and pushes a pointer to it onto the stack.
       6
       7
       8      size mode(ps);          $ mode keyword 'set'
       9      size elmt(ps);          $ mode of elements
      10
      11
      12      pop2(elmt, mode);
      13
      14      if (is_funt(elmt) ! is_floc(elmt)) call ermsg(72, 0);
      15
      16      countup(formtabp, formtab_lim, 'formtab');
      17      formtab(formtabp) = 0;
      18      ft_type(formtabp) = f_uset;
      19      ft_elmt(formtabp) = elmt;
      20
      21      push1(hashf1(0));
      22
      23
      24      end subr gtset;
       1 .=member gtmap1
       2      subr gtmap1;
       3
       4$ this is the main routine for processing map types.
       5$
       6$ the top entries on the stack are:
       7$
       8$ 1. the mode of the range
       9$ 2. a counter n
      10$ 3. n+1 domain modes
      11$ 4. a mode keyword, one of 'smap', 'mmap'
      12
      13
      14      size range(ps);         $ mode of map range
      15      size n(ps);             $ number of domains - 1
      16      size domain(ps);        $ mode of map domain
      17      size mode(ps);          $ mode keyword
      18      size map_code(ps);      $ map code corresponding to mode
      19      size rng_elmt(ps);      $ single range element
      20      size map_elmt(ps);      $ map element (pair)
      21      size imset(ps);         $ range set type (ambiguous maps only)
      22
      23
      24      pop2(range, n);
      25
      26      if n > 0 then           $ build tuple describing domain
      27          push1(n-1);   call gttup1;
      28      end if;
      29
      30      pop2(domain, mode);
      31
      32      if     mode = sym_msmap then map_code = ft_smap;
      33      elseif mode = sym_mmap  then map_code = ft_map;
      35      elseif mode = sym_mmmap then map_code = ft_mmap;
      36      end if;
      37
      38      $ find the map element type.  note that when we extract an
      39      $ element from an untyped map we always get a pair whose
      40      $ components are both typed.
      41      if map_code = ft_mmap then
      42          rng_elmt = ft_elmt(range);
      43
      44      elseif ft_type(range) = f_uint then
      45          rng_elmt = f_int;
      46
      47      elseif ft_type(range) = f_ureal then
      48          rng_elmt = f_real;
      49
      50      else
      51          rng_elmt = range;
      52      end if;
      53
      54      push3(domain, rng_elmt, 0);   call gttup1;   pop1(map_elmt);
      55
      56      if map_code = ft_map then
      57          push2(sym_mset, rng_elmt); call gtset; pop1(imset);
      58      else
      59          imset = 0;
      60      end if;
      61
      62      if (is_funt(domain) ! is_floc(domain)) call ermsg(73, 0);
      63      if (is_floc(range))                    call ermsg(74, 0);
      64
      65      countup(formtabp, formtab_lim, 'formtab');
      66      formtab(formtabp) = 0;
      67      ft_type(formtabp) = map_type(range);
      68      ft_mapc(formtabp) = map_code;
      69      ft_elmt(formtabp) = map_elmt;
      70      ft_dom(formtabp)  = domain;
      71      ft_im(formtabp)   = range;
      72      ft_imset(formtabp) = imset;
      73
      74      push1(hashf1(0));
      75
      76
      77      end subr gtmap1;
       1 .=member gtsmap
       2      subr gtsmap;
       3
       4$ this routine processes the mode 'smap'.  we treat it as a short
       5$ hand for 'smap(general) general'.
       6
       7      push3(f_gen, 0, f_gen);   call gtmap1;
       8
       9      end subr gtsmap;
       1 .=member gtmmp1
       2      subr gtmmp1;
       3
       4$ this routine processes 'mmap(t1, t2, ..., tn) tn+1'.  we treat it as
       5$ 'mmap<> set(tn+1)'.
       6
       7
       8      size elmt(ps);          $ mode of set elements
       9
      10
      11      pop1(elmt);   push2(sym_mset, elmt);   call gtset;
      12
      13      call gtmap1;
      14
      15
      16      end subr gtmmp1;
       1 .=member gtmmp2
       2      subr gtmmp2;
       3
       4$ this routine processes 'mmap<> tn+1'.  we check that
       5$ the range mode is a set mode.
       6
       7
       8      size mode(ps);          $ range mode
       9
      10
      11      mode = astack(asp);
      12
      13      if ^ is_fset(mode) then
      14          call ermsg(13, 0);
      15          astack(asp) = f_uset;
      16      end if;
      17
      18      call gtmap1;
      19
      20
      21      end subr gtmmp2;
       1 .=member gtmmap
       2      subr gtmmap;
       3
       4$ this routine processes the mode 'mmap'.  we treat it as a short
       5$ hand for 'mmap<> set(general)'.
       6
       7
       8      push4(f_gen, 0, sym_mset, f_gen);
       9      call gtset;
      10      call gtmap1;
      11
      12
      13      end subr gtmmap;
       1 .=member gtprc1
       2      subr gtprc1;
       3
       4$ this routine processes the type 'proc(t1 ... tn+1)tn+2'.
       5
       6      size j(ps),  $ loop index
       7           n(ps),   $ number of argument types-1
       8           type(ps),  $ argument type
       9           rtyp(ps);  $ result type
      10
      11
      12      pop2(rtyp, n);  $ result type and no. of args-1
      13
      14      countup(formtabp, formtab_lim, 'formtab');
      15      formtab(formtabp) = 0;
      16
      17      ft_type(formtabp) = f_proc;
      18      ft_elmt(formtabp) = mttabp;
      19
      20      ft_lim(formtabp) = n+2;
      21
      22$ enter argument types in mttab.
      23
      24$ push the result type, then processes it along with the argument
      25$ types.
      26      push1(rtyp);
      27
      28      do j = 1 to n+2;
      29          type = astack(asp-n-2+j);
      30
      31          countup(mttabp, mttab_lim, 'mttab');
      32          mttab(mttabp)  = type;
      33      end do;
      34
      35
      36      free_stack(n+2);  $ pop astack
      37
      38      push1(hashf2(0));
      39
      40
      41      end subr gtprc1;
       1 .=member gtprc2
       2      subr gtprc2;
       3
       4$ this routine processes the type 'proc'.
       5
       6      push1(f_proc);
       7
       8
       9      end subr gtprc2;
       1 .=member gtprc3
       2      subr gtprc3;
       3
       4$ this routine processes 'proc(t1 ... tn)'.
       5
       6      push1(f_gen);  $ result type
       7      call gtprc1;
       8
       9
      10      end subr gtprc3;
       1 .=member gtprc4
       2      subr gtprc4;
       3
       4$ this procedure processes 'procedure () mode'.
       5
       6      size mode(ps);          $ result mode
       7
       8
       9      pop1(mode);
      10
      11      countup(formtabp, formtab_lim, 'formtab');
      12      formtab(formtabp) = 0;
      13
      14      ft_type(formtabp) = f_proc;
      15      ft_elmt(formtabp) = mttabp;
      16      ft_lim(formtabp)  = 1;
      17
      18      countup(mttabp, mttab_lim, 'mttab');
      19      mttab(mttabp) = mode;
      20
      21      push1(hashf2(0));
      22
      23
      24      end subr gtprc4;
       1 .=member gdef1
       2      subr gdef1;
       3
       4$ this routine is called after seeing 'proc ' in a procedure
       5$ definition.
       6
       7$ setl makes no distinction between subroutines and functions.
       8$ instead we assume that every procedure returns a value. this
       9$ value may be omega, and may be ignored by the caller.
      10
      11$ we begin by popping the routine name and checking that it has
      12$ appeared in an exports or procs statement but has not already
      13$ been defined.
      14
      15
      16      pop1(currout);
      17
      18      if (^ is_proc(currout)) call ermsg(57, currout);
      19      if (is_seen(currout))   call ermsg(23, currout);
      20
      21      curunit   = currout; $ set unit type, etc.
      22      unit_type = unit_proc;
      23
      24      is_seen(currout) = yes;  $ indicate seen
      25
      26$ emit entry instruction then allocate exit and stop labels
smfb 139      call incode;            $ re-initialise code table.
      27      call emit(q1_entry, currout, 0, 0);
      28      estmt_count = cstmt_count;   $ statement number of procedure entry
      29
      30      stop_lab = getlab(0);
      31      exit_lab = getlab(0);
      32
      33
      34      end subr gdef1;
       1 .=member gdef2
       2      subr gdef2;
       3
       4$ this routine is called after seeing proc(x1 ... xn(*)).
       5
       6      size n(ps);   $ number of parameters-1
       7
       8      pop1(n);
       9      call gdef(n+1, yes);
      10
      11
      12      end subr gdef2;
       1 .=member gdef3
       2      subr gdef3;
       3
       4$ this routine is called after seeing a procedure or operator
       5$ definition with zero parameters.
       6
       7      call gdef(0, no);
       8
       9
      10      end subr gdef3;
       1 .=member gdef4
       2      subr gdef4;
       3
       4$ this routine is called at the start of a procedure(as opposed to
       5$ operator) definition.
       6
       7      op_flag = no;
       8
       9
      10      end subr gdef4;
       1 .=member gdef5
       2      subr gdef5;
       3
       4$ this routine is called at the start of an operator definition.
       5
       6      op_flag = yes;
       7
       8
       9      end subr gdef5;
       1 .=member gdef6
       2      subr gdef6;
       3
       4$ this routine is called after seeing proc p(x1 ... xn).
       5
       6      size n(ps);   $ number of arguments-1
       7
       8      pop1(n);
       9      call gdef(n+1, no);
      10
      11
      12      end subr gdef6;
       1 .=member gdef
       2      subr gdef(n, vary);
       3
       4$ this routine is called at the end of a procedure or op
       5$ definition.
       6
       7
       8      size n(ps),  $ number of arguments
       9           vary(1); $ flags variable number of arguments
      10
      11      size fm(ps),  $ form of routine
      12           j(ps),  $ loop index
      13           reprd(1),  $ on if parameters are reprd.
      14           morg(ps), $ origin in mttab
      15           org(ps),  $ origin in astack
      16           vp(ps),   $ vptr for routine
      17           mode(ps),  $ mode of parameter
      18           param(ps);  $ parameter name
      19
      20
      21$ user defined operators can have at most two parameters.
      22      if (op_flag & (n > 2 ! vary)) call ermsg(68, currout);
      23
      24$ see if 'n' and 'vary' agree with the procedures declaration.
      25
      26      vp = vptr(currout);
      27
      28      if (vary ^= val(vp+1) ! n ^= val(vp+2)) call ermsg(7, currout);
      29
      30$ see if the user has supplied a detailed repr for the procedure.
      31$ if so, we will use it to repr the formal parameters.
      32
      33      reprd = (is_repr(currout) & form(currout) ^= f_proc);
      34
      35      if (reprd) morg = ft_elmt(form(currout));
      36
      37$ process arguments one at a time, comparing their modes with
      38$ those given in the procedure value.
      39
      40      org = asp - 2 * n;  $ origin in astack
      41
      42      do j = 1 to n;
      43          param = astack(org + 2 * j);
      44          mode  = astack(org + 2 * j - 1);
      45
      46          if is_decl(param) then
      47              call ermsg(41, param);
      48
      49          elseif mode ^= val(vp+2+j) then
      50              call ermsg(41, param);
      51
      52          else
      53              is_decl(param)  = yes;
      54
      55              if reprd then
      56                  form(param)    = mttab(morg+j);
      57                  is_repr(param) = yes;
      58              end if;
      59
      60              is_read(param)  = yes;
      61              if (mode ^= sym_rd) is_write(param) = yes;
      62              is_store(param) = yes;
      63              is_param(param) = yes;
      64          end if;
      65      end do;
      66
      67      free_stack(2 * n);
      68
      69
      70      end subr gdef;
       1 .=member gendr1
       2      subr gendr1;
       3
       4$ this routine is called at the end of each subroutine or function.
       5$ we define the routines exit and stop blocks, close its scope, then
       6$ call 'blkdec' to put the code for the routine into the exact form
       7$ desired by the optimizer.
       8$
       9$ note that we define the exit block before the stop block.
      10$ this means we will return automaticly if we execute an end
      11$ statement.
      12
      13
      14      size j(ps);             $ loop index
      15
      16
      17      call deflab(exit_lab);
      18      call emit(q1_exit, currout, 0, 0);
      19
      20      call deflab(stop_lab);
      21      call emit(q1_stop, 0, 0, 0);
      22
      23$ check that all labels appearing in explicit gotos have been defin
      24
      25      do j = symtab_org to symtabp;
      26          if is_perf(j) then
      27              if ^ is_seen(val(vptr(j))) then
      28                  push1(j); call gperf1;  $ build a dummy perform block,
      29                  call ermsg(25, j);      $ mark it as erroneous,
      30                  call gperf2;            $ and close it.
      31              end if;
      32          end if;
      33
      34          if ft_type(form(j)) = f_lab then
      35              if ^ is_seen(j) then
      36                  push1(j); call glabel; $ build a dummy definition
      37                  if is_internal(j) then $ this is a compiler error
      38                      call ermsg(26, j); $ mark it as erroneous
      39                  else                   $ this is a user error
      40                      call ermsg(27, j); $ mark it as erroneous
      41                  end if;
      42              end if;
      43          end if;
      44      end do;
      45
      46      call blkdec;  $ call cleanup pass
      47
      48
      49      end subr gendr1;
       1 .=member gendr2
       2      subr gendr2;
       3
       4$ this routine is called after the tables for a procedure have
       5$ been written. we restore the previous scope.
       6
       7      curunit   = curmemb;
       8      unit_type = memb_type;
       9      currout   = 0;
      10
      11
      12      end subr gendr2;
       1 .=member gendb
       2      subr gendb;
       3
       4$ this routine is called at the end of a routine body, before the
       5$ first perform block. we generate 'return om' so that control
       6$ never flows from the body to the first perform block.
       7
       8      call gret2;
       9
      10
      11      end subr gendb;
       1 .=member gperf1
       2      subr gperf1;
       3
       4$ this routine opens a perform block. we pop the perform block and
       5$ make sure that it has appeared previously in a perform-call. we
       6$ then find its entry label from its val entry and define it.
       7
       8
       9      size lab(ps);   $ label for start of perform block
      10
      11
      12      pop1(curperf);
      13
      14      if ^ is_perf(curperf) then
      15          call ermsg(35, curperf);
      16      else
      17          lab = val(vptr(curperf));
      18          call deflab(lab);
      19      end if;
      20
      21
      22      end subr gperf1;
       1 .=member gperf2
       2      subr gperf2;
       3
       4$ this routine is called at the end of a perform block.
       5$ we emit an 'exit' statement then set curperf = 0.
       6
       7      call gexit;
       8      curperf = 0;
       9
      10
      11      end subr gperf2;
       1 .=member glabel
       2      subr glabel;
       3
       4$ this routine processes user defined labels. we pop the label from
       5$ astack and define it.
       6
       7
       8      size lab(ps);  $ label
       9
      10
      11      pop1(lab);
      12
smfb 140      if is_decl(lab) & symtype(lab) ^= f_lab then
smfb 141          call ermsg(21, lab);
smfb 142      else
smfb 143          is_decl(lab) = yes;
smfb 144          is_repr(lab) = yes;
smfb 145          form(lab)    = f_lab;
smfb 146
smfb 147          call deflab(lab);
smfb 148      end if;
      18
      19
      20      end subr glabel;
       1 .=member gstat1
       2      subr gstat1;
       3
       4$ reset ustmt_count.
       5
       6      cstmt_count = cstmt_count + 1;
       7      ustmt_count = cstmt_count;
       8      estmt_count = 0;
       9
      10
      11      end subr gstat1;
       1 .=member gstat
       2      subr gstat;
       3
       4$ this routine is called at the start of every statement. we
       5$ do three things:
       6
       7$ 1. increment the statement counter
       8$ 2. emit a q1_stmt instruction
       9$ 3. if desired, we check that the code fragment from prog_start
      10$    to prog_end is one continuous list.
      11
      12      size p(ps);  $ code pointer
      13
      14      cstmt_count = cstmt_count + 1;
      15
      16      call emit(q1_stmt, 0, 0, 0);
      17
      18      if chk_flag then
      19          p = prog_start;
      20
      21          while next(p) ^= 0;
      22              p = next(p);
      23          end while;
      24
      25          if p ^= prog_end then
      26              put, skip, column(7),
      27                   '**** prog check failed at stmt ':
      28                   stmt_count, il, '****', skip(2);
      29
      30              call ltlfin(1, 0);  $ abort with dump
      31          end if;
      32      end if;
      33
      34$ dump astack if requested
      35      if trs_flag then
      36          put, skip, 'statement number: ': stmt_count, i, skip;
      37          stack_trace('astack: ', asp);
      38      end if;
smfb 149
smfb 150      $ clear bstack, the stack used to process boolean operations.
smfb 151      bsp = 0;
      39
      40
      41      end subr gstat;
       1 .=member gerror
       2      subr gerror;
       3
       4$ this routine is called at the point of each syntax error. it
       5$ clears astack and advances the polish string to the start of
       6$ the next statement.
       7
       8      size tp(ps),  $ node type
       9           vl(ps); $ node value
      10
      11
      12      if unit_type = unit_proc then
      13          call emit(q1_error, 0, 0, 0);
      14      end if;
      15
      16      asp = 0;   $ reset astack
      17
      18      while 1;
      19          getp(tp, vl);
      20          if (filestat(pol_file, end)) quit;
      21
      22          if (tp = pol_mark & vl = p_stat) quit;
      23      end while;
      24
      25      call gstat;  $ increment statement counter
      26
      27
      28      end subr gerror;
       1 .=member gpcall
       2      subr gpcall;
       3
       4$ this routine generates a 'call' to a perform block 'p'. this is
       5$ done in three steps:
       6
       7$ 1. pop 'p' and see if it has already been used. if so, issue an
       8$    error message, since a perform block can only be called from
       9$    one place. otherwise set p's is_decl and is_perf fields.
      10
      11$ 2. obtain two labels 'l1' and 'l2', then emit 'go to l1; /l2/'.
      12
      13$ 3. make a val entry for the perform block. this will consist
      14$    of two words, the first giving l1 and the second giving l2.
      15
      16
      17      size p(ps),   $ perform block name
      18           l1(ps),  $ label for perform block
      19           l2(ps);  $ label for return point
      20
      21
      22      pop1(p);
      23
      24      if is_decl(p) then
      25          call ermsg(33, p);
      26
      27      else
      28          is_decl(p) = yes;
      29          is_perf(p) = yes;
      30
      31          l1 = getlab(0);   $ get labels
      32          l2 = getlab(0);
      33
      34          call emit(q1_goto, l1, 0, 0);
      35          call deflab(l2);
      36
      37$ make val entry
      38          vptr(p) = valp+1;
      39          vlen(p) = 2;
      40
      41          if (valp + 2 > val_lim) call overfl('val');
      42
      43          val(valp+1) = l1;
      44          val(valp+2) = l2;
      45          valp = valp+2;
      46      end if;
      47
      48
      49      end subr gpcall;
       1 .=member gcall1
       2      subr gcall1;
       3
       4$ this routine generates a zero argument procedure call.
       5
       6
       7      size nam(ps);           $ routine or perform block name
       8
       9
      10      nam = astack(asp);
      11
      12      if is_decl(nam) then
      13          call gcall(0);      $ routine with zero parameters
      14      else
      15          call gpcall;        $ invocation of perform block
      16      end if;
      17
      18
      19      end subr gcall1;
       1 .=member gcall2
       2      subr gcall2;
       3
       4$ this routine processes call statements with arguments.
       5
       6      size n(ps);  $ number of arguments-1
       7
       8      pop1(n);
       9
      10      call gcall(n+1);
      11
      12
      13      end subr gcall2;
       1 .=member gcall3
       2      subr gcall3;
       3
       4$ this routine processes '<*name> ( ) ;', i.e. a routine call with zero
       5$ parameters.  unlike for 'gcall1', we know that it can not be a perform
       6$ block definition.
       7
       8
       9      call gcall(0);
      10
      11
      12      end subr gcall3;
       1 .=member gcall
       2      subr gcall(n);
       3
       4$ this routine generates an n-argument procedure call.
       5
       6$ procedure calls always return a value. this is done by assigning
       7$ the returned value to the name of the procedure.
       8
       9$ a calling sequence consists of two parts:
      10
      11$ 1. the actual call
      12$ 2. the code to save the returned value in a temporary.
      13
      14$ this routine generates (1), while 'gfcall' generates both (1) and
      15$ (2).
      16
      17$ we generate the call in three steps:
      18
      19$ 1. generate a series of 'argin' assignments to assign the arguments
      20$    to the run time stack.
      21
      22$ 2. generate the actual call.
      23
      24$ 3. generate argout assignments assigning the stack entries back to
      25$    the arguments.
      26
      27$ calls to procedures with a variable number of arguments are
      28$ treated in one of two ways:
      29
      30$ 1. if we are calling a built in procedure we treat it as if it
      31$    has 'n' arguments and generate an argin and argout assignment
      32$    for each.
      33
      34$ 2. otherwise we gather all the extra arguments into a tuple
      35$    and generate argin and argout assignments for the tuple.
      36
      37      size n(ps);   $ number of arguments
      38
      39      size rout(ps),  $ routine name
      40           vp(ps),    $ its val pointer
      41           na(ps),    $ its declared no. of arguments
      42           vary(1),   $ indicates variable no. of arguments
      43           bip(1),    $ flags built in procedure
      44           bnum(1),   $ standard no. of args for built in proc
      45           bvary(1),  $ flags built in proc with variable no. of args
      46           j(ps),     $ loop index
      47           t(ps),     $ temp for argout
      48           arg(ps),   $ argument
      49           mode(ps);  $ its mode
      50      size temp(ps);          $ internal variable for in-conversion
      51
      52
      53$ get routine name and various pointers.
      54
      55      rout = astack(asp-n);
      56
      57      if ^ is_proc(rout) then  $ not procedure
      58          call ermsg(43, rout);
      59          free_stack(n+1);
      60          return;
      61
      62      elseif ^ is_avail(rout) then  $ not imported
      63          call ermsg(77, rout);
      64          free_stack(n+1);
      65          return;
      66      end if;
      67
      68      vp    = vptr(rout);
      69      vary  = val(vp+1);
      70      na    = val(vp+2);
      71
      72      bip   = is_bip(rout);
      73      bnum  = na;
      74      bvary = bip & vary;
      75
      76      if vary then
      77          if n < na-1 then
      78              call ermsg(62, rout);
      79              free_stack(n+1);
      80              return;
      81
      82          elseif bip then
      83              vary  = no;
      84              na    = n;
      85
      86          elseif n = na-1 then
      87              push1(sym_nulltup);
      88          else
      89              push1(n-na);
      90              call gtup3;
      91          end if;
      92
      93      elseif n ^= na then
      94          call ermsg(62, rout);
      95
      96          free_stack(n+1);
      97          return;
      98      end if;
      99
     100
     101$ generate argins. note that write only arguments are initialized
     102$ to omega. if the procedure has a variable number of arguments
     103$ and they are all write only, we initialize the corresponding tuple
     104$ to nult.
     105
     106      do j = 1 to na;
     107          arg  = astack(asp-na+j);
     108          mode = val(vp+2+j);
     109          if (bvary & j > bnum) mode = val(vp+2+bnum);
     110
     111          if mode = sym_wr then
     112              arg = sym_om;
     113              if (vary & j = na) arg = sym_nulltup;
     114          end if;
     115
     116          if ft_type(form(arg)) = f_elmt then
     117              $ need assignment for conversion
     118              temp = getvar(0);   call emit(q1_asn, temp, arg, 0);
     119              arg  = temp;
     120          end if;
     121
     122          call emit(q1_argin, arg, rout, getint(j));
     123      end do;
     124
     125
smfb 152      $ start the call block:  the optimiser assumes that each procedure
smfb 153      $ call is contained in a single-instruction block.
smfb 154      if is_bip(rout) = no then call deflab(getlab(0)); end if;
     126      $ emit call
     127      call emit(q1_call, rout, getint(n), 0);
smfb 155
smfb 156      $ end the call block.
smfb 157      if is_bip(rout) = no then call deflab(getlab(0)); end if;
     128
     129
     130$ iterate over arguments, emitting argouts. there are three
     131$ possibilities for each argument
     132
     133$ 1. it is read only. emit a q1_free instruction.
     134
     135$ 2. it is a general left hand side. emit an argout to a temporary
     136$    and a sinister assignment.
     137
     138$ 3. otherwise simply emit an argout.
     139
     140$ note that if a general left hand side is used as a read-write
     141$ argument then we must copy its code fragment before emitting
     142$ the sinister assignment.
     143
     144      do j = na to 1 by -1;
     145          arg  = astack(asp-na+j);
     146          mode = val(vp+2+j);
     147          if (bvary & j > bnum) mode = val(vp+2+bnum);
     148
     149          if mode = sym_rd then
     150              call emit(q1_free, arg, rout, getint(j));
     151
     152          elseif ^ is_write(arg) & ^ is_param(arg) then
     153              call ermsg(53, arg);
     154
     155          elseif is_temp(arg) then   $ general left hand side
     156              if (mode = sym_rw) arg = copy(arg);
     157              t   = gettmp(0);
     158
     159              call emit(q1_argout, t, rout, getint(j));
     160              call gasn(arg, t, no);
     161
     162          else
     163              call emit(q1_argout, arg, rout, getint(j));
     164          end if;
     165      end do;
     166
     167      free_stack(na+1);
     168
     169
     170      end subr gcall;
       1 .=member gasn
       2      subr gasn(lhs, rhs, iterflag);
       3
       4$ this is the main routine for generating assignments. 'rhs' is
       5$ the right hand side of the assignment, and 'lhs' is a model
       6$ which tells us how to generate the assignment. lhs
       7$ is one of the following:
       8
       9$ 1. a variable 'v' . this indicates that we should emit the
      10$    simple assignment 'v = rhs'.
      11
      12$ 2. a temporary generated by an expression 't := [a, b]'.
      13$    this indicates that we should emit the multiple
      14$    assignment '[a, b] := rhs'.
      15
      16$ 3. a temporary generated by a retrieval operation 't = f(x)'.
      17$    this indicates that we should generate the sinister
      18$    assignment 'f(x) = y'.
      19
      20$ note that in case (2) we could just as well have
      21$ 't := [ [a, b], f(x)]'. here we must proceed recursively
      22$ along the components of the tuple, emitting each of the
      23$ inner assignments in order.
      24
      25$ we handle this recursion by using the top of 'astack' as
      26$ a workpile. we begin by saving a pointer to the top of
      27$ astack, then pushing 'lhs' and 'rhs'. we then iterate
      28$ until the stack is 'empty', popping pairs from the
      29$ stack and processing assignments.
      30
      31$ compound assignments are processed by pushing the
      32$ appropriate pairs onto the stack. simple assignments
      33$ are handled in line, and sinister assignments are
      34$ handled by a lower level routine, 'gsin'.
      35
      36$ note that compound assignments of the form
      37
      38$    [a, -] := [1, 2];
      39
      40$ appear as:
      41
      42$   [a, .om] := [1, 2];
      43
      44$ such assignments to omega on an inner level are treated as noops.
      45$ for a fuller explanation, see 'gdash'.
      46
      47$ for iterators, we allow [ x1, x2, ..., xn ] := om to undefine all
      48$ iteration variables at the end of the iteration.  this is the only
      49$ context in which we allow omega as the right-hand side of a compound
      50$ assignment.  in this context, we replace the compound assignment by
      51$ the sequence x1 := om; x2 := om; ..., xn := om.
      52$
      53$ setl permits assignments to read-only parameters.  it does, however,
      54$ copy only those parameters back to the caller which were declared
      55$ as 'wr' or 'rw'.
      56
      57
      58      size lhs(ps),   $ original lhs
      59           rhs(ps);   $ original rhs
      60      size iterflag(1);      $ flags iterators
      61
      62      size savep(ps),  $ saved value of asp
      63           l(ps),      $ current lhs
      64           r(ps);      $ current rhs
      65
      66      size j(ps),      $ index over tuple components
      67           var(ps),  $ internal variable
      68           l1(ps),     $ inner lhs
      69           r1(ps),     $ inner rhs
      70           inst(ps),   $ instruction defining 'l'
      71           op(ps);     $ its opcode
      72      size i(ps);             $ instruction defining r
      73      size fm(ps);           $ form of right-hand side
      74
      75      size goft(ps);  $ emits y = f(x) for tuples
      76
      77
      78      savep = asp;   $ save astack pointer, then push [lhs, rhs].
      79      push2(lhs, rhs);
      80
      81      until asp = savep;
      82          pop2(r, l);
      83
      84          if is_temp(l) then
      85$ l is probably a retrieval or tuple former. find the instruction
      86$ which defined it, and branch on its opcode.
      87              inst = tlast(l);   $ instruction defining l.
      88              op = opcode(inst);
      89
      90              if op = q1_tup then  $ multiple assignment
      91
      92$ if 'r' is an expression, we begin by assigning it to an internal
      93$ variable. we then iterate for j := 1 ... ? l, pushing l(j)
      94$ and r(j) onto the stack.
smfb 158
smfb 159$$== nb. this routine has been modified to generate better code for
smfb 160$$==       (forall [ x, y ] in f) ... end forall;
smfb 161$$== and
smfb 162$$==       [ x, y ] := f(z)
smfb 163$$== when f, x, and y are repred appropriately (as is the case in the
smfb 164$$== optimiser).  the new code would not detect if one wrote
smfb 165$$==       [ x, y ] := 'ab'    or    [ x, y ] := < [ 1, 1 ], [ 2, 4 ] !
smfb 166$$== which is not permitted.
      95
      96                  if is_temp(r) then
      97                      i = tlast(r);   $ instruction defining r
      98                      if opcode(i) = q1_asn then
      99                          $ use the form of the input of the assignment
     100                          $ rather than the form of the right-hand side
     101                          fm = form(arg2(i));
     102                      else
     103                          fm = form(r);
     104                      end if;
     105                  else
     106                      fm = form(r);
     107                  end if;
     108
     109                  if ft_type(fm) = f_elmt then
     110                      $ compute the form of the value
     111                      while ft_type(fm) = f_elmt;
     112                          if (ft_type(ft_base(fm)) = f_pbase) quit;
     113                          fm = ft_elmt(ft_base(fm));
     114                      end while;
     115
     116                      $ create a split variable and emit a conversion
     117                      var = getvar(0);
     118
smfb 167$$==                  if (fm = f_gen) fm = f_tuple;
smfb 168$$==                  if ( ^ is_ftup(fm)) call ermsg(84, r);
smfb 169$$++
smfb 170                      if ^ (is_ftup(fm) ! fm = f_gen) then
smfb 171                          call ermsg(84, r);
smfb 172                      end if;
smfb 173$$--
     121
     122                      form(var) = fm;   is_repr(var) = yes;
     123                      call emit(q1_asn, var, r, 0, 0);   r = var;
     124
smfb 174$$==              elseif is_temp(r) ! (r ^= sym_om & fm = f_gen) then
smfb 175$$++
smfb 176                  elseif is_temp(r) then
smfb 177$$--
     126                      var = getvar(0);
     127
smfb 178$$==                  if (fm = f_gen) fm = f_tuple;
smfb 179$$==                  if ( ^ is_ftup(fm)) call ermsg(84, r);
smfb 180$$++
smfb 181                      if ^ (is_ftup(fm) ! fm = f_gen) then
smfb 182                          call ermsg(84, r);
smfb 183                      end if;
smfb 184$$--
     130
     131                      form(var) = fm;   is_repr(var) = yes;
     132                      call emit(q1_asn, var, r, 0, 0);   r = var;
     133
smfb 185$$==              elseif ^ (is_ftup(fm) ! (iterflag & r = sym_om)) then
smfb 186$$++
smfb 187                  elseif r = sym_om & ^ iterflag then
smfb 188                      call ermsg(84, r);
smfb 189
smfb 190                  elseif ^ (is_ftup(fm) ! fm = f_gen) then
smfb 191$$--
     135                      call ermsg(84, r);
     136                  end if;
     137
     138                  do j = nargs(inst)-1 to 1 by -1;
     139                      l1 = argn(inst, j+1);  $ j-th component of l
     140                      if (l1 = sym_om) cont;
     141
     142                      if (iterflag & r = sym_om) then
     143                          r1 = sym_om;
     144                      else
     145                          r1 = goft(r, j);    $ temp for 'r(1)'
     146                      end if;
     147
     148                      push2(l1, r1);
     149                  end do;
     150
     151$ change tuple former to a noop.
     152                  opcode(inst) = q1_noop;
     153                  is_store(arg1(inst)) = no;
     154
     155              elseif sinmap(op) ^= 0 then  $ retrieval operation
     156                  call gsin(l, r);
     157
     158              else  $ some other expression
     159                  call ermsg(18, 0);
     160              end if;
     161
     162          elseif ^ is_write(l) & ^ is_param(l) then
     163              call ermsg(19, l);
     164
     165          else    $ simple assignment
     166              call emit(q1_asn, l, r, 0);
     167          end if;
     168      end until;
     169
     170
     171      end subr gasn;
       1 .=member gsin
       2      subr gsin(lhs, rhs);
       3
       4$ this routine generates sinister assignments 'lhs := rhs'.
       5$ 'lhs' is a temporary generated by an of, ofa, or ofb
       6$ operation.  we map the code which generated 'lhs' into
       7$ the corresponding sinister assignment.
       8
       9
      10      size lhs(ps);           $ left hand side
      11      size rhs(ps);           $ right hand side
      12
      13      size targ(ps);          $ target of code motion
      14      size model(ps);         $ model instruction for assignment
      15      size r(ps);             $ current right hand side
      16      size op(ps);            $ retrieval opcode
      17      size rmap(ps);          $ map we retrieve from
      18      size lmap(ps);          $ map we store into
      19      size indx(ps);          $ index for assignment
      20      size sinop(ps);         $ sinister assignment opcode
      21      size last(ps);          $ last retrieval operation
      22
      23      size a(ps);             $ array of arguments
      24      dims a(4);
      25
      26
      27$ we begin by moving the code for lhs to the end of the
      28$ program so that it is executed after the code for rhs.
      29
      30      targ = prog_end;   last = tlast(lhs);
      31      call movblk(tprev(lhs), last, targ);
      32
      33$ next we find the retrieval instruction which created 'lhs'.
      34$ we use this instruction as a model to emit the appropriate
      35$ assignment.
      36
      37$ 'lhs' will generally be the result of some expression such
      38$ as 't := f(x1 ... xn)', that is it will be the result of a
      39$ series of retrieval instructions which start with a program
      40$ variable and continue accessing pieces of more deeply nested
      41$ maps. the corresponding assignment must start by assigning
      42$ to the innermost map, then keep generating assignments until
      43$ it stores into a variable.
      44
      45$ note that the parser will accept '(a+b) (1)' as a valid left
      46$ hand side. thus as we generate assignments we must watch out
      47$ for errors. we use an array called sinmap to map retrieval opcodes
      48$ into the corresponding storage opcodes. if we find a
      49$ storage opcode of 0, it means that we have an illegal
      50$ expression used as a left hand side.
      51
      52
      53      model = last;           $ model instruction for assignment
      54      r     = rhs;            $ current right hand side
      55
      56      while 1;
      57          op   = opcode(model);  $ get map name and opcode
      58          rmap = arg2(model);
      59
      60          if ^ is_write(rmap) & ^ is_param(rmap) then
      61              call ermsg(53, rmap);
      62          end if;
      63
      64          if model ^= last then
      65              call reuse(model, 2);   call reuse(model, 3);
      66          end if;
      67
      68          lmap = arg2(model);   indx = arg3(model);
      69
      70          if op = q1_subst then  $ substring assignments
      71              if (model ^= last) call reuse(model, 4);
      72
      73              a(1) = lmap;
      74              a(2) = indx;
      75              a(3) = arg4(model);  $ length of substring
      76              a(4) = r;
      77
      78              call emitn(q1_ssubst, a, 4);
      79
      80          else
      81              sinop = sinmap(op);  $ get sinister opcode
      82              if (sinop = 0) go to error;
      83
      84              call emit(sinop, lmap, indx, r);
      85          end if;
      86
      87$ if 'map' is a variable we're done. otherwise we must store
      88$ it back in the map it came from.
      89
      90          if (^ is_temp(rmap)) quit while;
      91
      92          model = tlast(rmap);
      93          r     = lmap;
      94      end while;
      95
      96$ change the 'of' instruction which created 'lhs' to a noop.
      97      opcode(last) = q1_noop;
      98      is_store(lhs) = no;
      99
     100      return;
     101
     102/error/     $ found bad left hand side
     103
     104      call ermsg(18, 0);
     105
     106      return;
     107
     108      end subr gsin;
       1 .=member gif1
       2      subr gif1;
       3
       4$ this routine is called after seeing the keyword 'if'.
       5$ we generate a cstack entry and get the 'else' and 'end'
       6$ labels.
       7
       8$ make cstack entry
       9      countup(csp, cstack_lim, 'cstack');
      10      cstack(csp) = 0;
      11      cs_type(csp) = cs_if;
      12
      13$ get labels for else and end.
      14      cs_else(csp) = getlab(0);
      15      cs_end(csp)  = getlab(0);
      16
      17
      18      end subr gif1;
       1 .=member gif2
       2      subr gif2;
       3
       4$ this routine is called after seeing 'if  then' or
       5$ 'elseif  then'. we emit 'if (^ exp) go to else-label'
       6
       7
smfb 192      size exp(ps);           $ symtab pointer for result of expression
smfb 193      size lab(ps);           $ else label
smfb 194
smfb 195
smfb 196      pop1(exp); lab = cs_else(csp);
smfb 197
smfb 198      if is_temp(exp) = yes & bsp >= 1 then
smfb 199        if exp = bs_temp(bsp) then
smfb 200          call gbool(q1_ifnot,exp,yes,bs_true(bsp),bs_false(bsp),lab);
smfb 201          bsp = bsp - 1;
smfb 202        else
smfb 203          call emit(q1_ifnot, exp, lab, 0);
smfb 204        end if;
smfb 205      else
smfb 206          call emit(q1_ifnot, exp, lab, 0);
smfb 207      end if;
      14
      15
      16      end subr gif2;
       1 .=member gif3
       2      subr gif3;
       3
       4$ this routine is called after seeing the last 'elseif' clause of
       5$ an if-statement. we emit 'go to end-label; /else-label/'.
       6$ this gives us a null 'else' clause if the user does not supply
       7$ one.
       8
       9      call emit(q1_goto, cs_end(csp), 0, 0);
      10
      11      call deflab(cs_else(csp));
      12
      13
      14      end subr gif3;
       1 .=member gif4
       2      subr gif4;
       3
       4$ this routine is called after seeing the end of an if-statement or
       5$ conditional expression. we must do three things:
       6
       7$ 1. define the 'end' label.
       8
       9$ 2. if this is a conditional expression(cs_temp ^= 0), we must
      10$    push the result of the expression onto the stack and set its
      11$    tlast field to point to the 'end' label.
      12
      13$ 3. pop cstack
      14
      15
      16      size temp(ps);  $ temp for result of conditional expression
      17
      18
      19      call deflab(cs_end(csp));
      20
      21      temp = cs_temp(csp);
      22
      23      if temp ^= 0 then
      24          tlast(temp) = prog_end;
      25          push1(temp);
      26      end if;
      27
      28      csp = csp-1;  $ pop cstack
      29
      30
      31      end subr gif4;
       1 .=member gif5
       2      subr gif5;
       3
       4$ this routine is called after seeing 'if  then  ...
       5$ elseif'. we emit 'go to end_label;  /else_label/', then obtain
       6$ a new else_label for the next else-clause.
       7
       8      call emit(q1_goto, cs_end(csp), 0, 0);
       9
      10      call deflab(cs_else(csp));
      11
      12      cs_else(csp) = getlab(0);
      13
      14
      15      end subr gif5;
       1 .=member gloop1
       2      subr gloop1;
       3
       4$ this routine is called at the start of a loop body. loops
       5$ have the form
       6
       7$    ( !  )  end;
       8
       9$ when we process the  we generate the code for
      10$ a complete loop with a null body. after we have processed
      11$ the actual loop body, we move it into the middle of the loop.
      12
      13$ in order to move the body, we must save a pointer to the last
      14$ instruction emitted before the body.
      15
      16      push1(prog_end);
      17
      18
      19      end subr gloop1;
       1 .=member gloop2
       2      subr gloop2;
       3
       4$ this routine is called after processing the entire loop body.
       5$ we pop a pointer to the start of the body, then move it into
       6$ the middle of loop.
       7
       8
       9      size prev(ps),   $ pointers to code fragment
      10           last(ps);
      11
      12
      13      pop1(prev);
      14      last = prog_end;
      15
      16      call gbody(prev, last);
      17      call endlp;
      18
      19
      20      end subr gloop2;
       1 .=member gcase1
       2      subr gcase1;
       3
       4$ this routine is called after seeing the key word 'case'. we
       5$ build a new cstack entry and get the 'end' and 'else' labels.
       6$ we also initilize the number of choices to 0.
       7
       8      countup(csp, cstack_lim, 'cstack');
       9      cstack(csp) = 0;
      10      cs_type(csp) = cs_case;
      11
      12$ fill in 'else' label and 'end' label. set the number of map elements
      13$ to zero.
      14      cs_else(csp) = getlab(0);
      15      cs_end(csp)  = getlab(0);
      16      cs_num(csp)  = 0;
      17
      18
      19      end subr gcase1;
       1 .=member gcase2
       2      subr gcase2;
       3
       4$ this routine is called after seeing 'case  of'. at this
       5$ point we emit two instructions:
       6
       7$ 1. q1_case:  look up  in a map and jump on the result
       8$              if it is defined.
       9
      10$ 2. q1_goto:  branch to the else label
      11
      12$ the map used in (1) is not built until the end of the case statement.
      13$ we save a pointer to the instruction and set its first argument later.
      14
      15$ since the case map is a constant, the optimizer can examine its
      16$ value to find the sucessors of the case statement.
      17
      18      size exp(ps);   $ expression for case jump
      19
      20      pop1(exp);
      21
      22      call emit(q1_case, 0, exp, 0);
      23      cs_jump(csp) = prog_end;
      24
      25      call emit(q1_goto, cs_else(csp), 0, 0);
      26
      27
      28      end subr gcase2;
       1 .=member gcase3
       2      subr gcase3;
       3
       4$ this routine is called after seeing the last choice in a case
       5$ statement. at this point we define the else label. if the
       6$ user has not supplied an 'else' clause, we will generate an empty one.
       7
       8      call deflab(cs_else(csp));
       9
      10
      11      end subr gcase3;
       1 .=member gcase4
       2      subr gcase4;
       3
       4$ this routine is called at the end of a case statement. we must
       5$ do four things:
       6
       7$ 1. finish building the case map
       8
       9$    we do this by pushing the number of tags-1 onto
      10$    the stack and calling 'gset3'. we then pop the result
      11$    and install it as the first argument of the jump
      12$    instruction.
      13
      14$ 2. define the end label
      15
      16$ 3. if this is a case expression(cs_temp ^= 0), we must push
      17$    the result of the expression onto the stack and set its
      18$    tlast field to point to the end label.
      19
      20$ 4. pop cstack.
      21
      22      size map(ps);           $ variable used to hold case map value
      23      size temp(ps);          $ temporary for result of case expression
      24      size fm(ps);            $ form of  in case  of
      25      size base(ps);          $ form of base (if form() = f_elmt)
      26      size prefix(ps);        $ based map prefix
smfb 208      size save_rpr_flag(ps); $ so we can overwrite repr-processing mode
smfb 209      size caseb(1);          $ indicates case map can be based
smfb 210      size caset(1);          $ indicates case 'map' can be tuple
smfb 211      size done(1);           $ indicates that case tags are sorted
smfb 212      size i(ps), j(ps);      $ loop indices
smfb 213      size exp(ps);           $ symbol table pointer for case expression
smfb 214      size nam(ps);           $ symbol table pointer for case tag
smfb 215      size max(ws);           $ maximum index for case tuple
smfb 216      size v(ws);             $ integer value (signed)
smfb 217
      28
      29$ first finish the setformer
      30
      31      if (cs_num(csp) >= vlen_lim) call overfl('too many cases');
      32
      39      $ if  of 'case  of...' has the form 'elmt b', then we
      40      $ generate the form 'remote smap(elmt b) label' for the case map;
      41      $ otherwise we generate the form 'smap(general) label'.
      42      save_rpr_flag = rpr_flag;   rpr_flag = 1;
smfb 218      exp = arg2(cs_jump(csp));  $  in 'case  of'
smfb 219      fm  = form(exp);  $ form of 
      44      base = ft_base(fm);     $ form of 's base (if any)
      45
      46      if ft_type(fm) = f_elmt & ft_type(base) ^= f_pbase then
smfb 220          caseb = yes;
smfb 221      else
smfb 222          caseb = no;
smfb 223      end if;
smfb 224
smfb 225      $ if all case tags are positive  integers within  a  dense  enough
smfb 226      $ range  we  repesent  the case 'map' as a tuple.  next we dermine
smfb 227      $ whether this is the case.
smfb 228
smfb 229      caset = yes; max = 0;
smfb 230
smfb 231      do j = 0 to cs_num(csp)-1;
smfb 232
smfb 233          $ astack(asp-j) is a pair [ tag, label ].   we  check  whether
smfb 234          $ the tag, i.e. the first component of the pair, is a positive
smfb 235          $ integer.   simultaneously  we determine the largest index to
smfb 236          $ avoid generating a very sparse tuple.
smfb 237
smfb 238          nam = symval(astack(asp-j));  $ first component of pair
smfb 239          if ^ is_fint(form(nam)) then caset = no; quit do; end if;
smfb 240          v = symval(nam); if v <= 0 then caset = no; quit do; end;
smfb 241          if (v > max) max = v;
smfb 242      end do;
smfb 243
smfb 244      +*  ebm_nw = 4  **  $ q2 map element block number of words
smfb 245      if (max > ebm_nw*cs_num(csp)) caset = no;
smfb 246
smfb 247      $ don't generate a tuple if this would cause an error which  would
smfb 248      $ not occur if we generated a map.
smfb 249      if max > cs_num(csp) then
smfb 250          if (max >= vlen_lim)  caset = no;
smfb 251          if (max >= nargs_lim) caset = no;
smfb 252      end if;
smfb 253
smfb 254      if caset = yes & max < cs_num(csp) then
smfb 255          $ there must be dublicate case tag values.
smfb 256          call ermsg(28, 0); caset = no;
smfb 257      end if;
smfb 258
smfb 259      if (opt_flag) caset = no;
smfb 260
smfb 261      if caseb = no & caset = yes then
smfb 262          if is_repr(exp) &
smfb 263                  ^ (is_fint(ft_deref(fm)) ! ft_deref(fm) = f_gen) then
smfb 264              call warn(07, 0);
smfb 265          end if;
smfb 266
smfb 267          $ sort the case tags into ascending order using bubble sort.
smfb 268          $ we can assume that typically they are almost sorted.
smfb 269
smfb 270          until done;
smfb 271              done = yes;  $ assume all sorted
smfb 272              do j = 1 to cs_num(csp)-1;
smfb 273                  if symval(symval(astack(asp-j+1))) <
smfb 274                          symval(symval(astack(asp-j))) then
smfb 275                      swap(astack(asp-j+1), astack(asp-j)); done = no;
smfb 276                  end if;
smfb 277              end do;
smfb 278          end until;
smfb 279
smfb 280          $ create dummy entries as required to get the full sequence of
smfb 281          $ short integers.   simultaneously  replace each  pair  by its
smfb 282          $ label,  i.e. its second component;  also delete the pairs as
smfb 283          $ we go along.   in the loop that follows,  i ranges  over the
smfb 284          $ original astack entries,  nam points to the i'th pair, and v
smfb 285          $ holds  the tag value  of the i'th pair;   j ranges  over the
smfb 286          $ case tuple components.
smfb 287
smfb 288          i = asp; nam = astack(i); v = symval(val(vptr(nam)));
smfb 289          get_stack(max - cs_num(csp));
smfb 290
smfb 291          do j = max to 1 by -1;
smfb 292              if v = j then  $ insert i'th entry at j'th position
smfb 293                  astack(asp-max+j) = val(vptr(nam)+1);
bnda  39                  assert is_internal(nam); assert is_ftup(form(nam));
bnda  40                  is_store(nam) = no;
smfe   9                  i = i - 1; if (i <= asp-max) cont do j;
smfb 297                  nam = astack(i); v = symval(val(vptr(nam)));
smfb 298              else
smfb 299                  astack(asp-max+j) = cs_else(csp);
smfb 300              end if;
smfb 301          end do;
smfb 302
smfb 303          $ generate the case tuple value
smfb 304          push1(max-1); call gtup3; pop1(map);
smfb 305      else
smfb 306          $ generate the case map value
smfb 307          push1(cs_num(csp)-1); call gset3; pop1(map);
smfb 308      end if;
smfb 309
smfb 310      $ insert the case map constant into the case instruction
smfb 311      arg1(cs_jump(csp)) = map;
smfb 312
smfb 313      $ finally, we repr the case map.
smfb 314      if caseb = no & caset = yes then  $ generate the form tuple(label)
smfb 315          push2(map, 0);
smfb 316          push2(f_lab, sym_zero);
smfb 317          call gttup2;        $ generate tuple(label)
smfb 318          call grepr;         $ and repr map: tuple(label);
smfb 319
smfb 320      elseif caseb = yes then
smfb 321          $ generate the form 'based smap(elmt b) label'.
smfb 322
      47          if is_local_repr(base) & ft_lim(base) > 0 then
      48              $ a constant base in the current scope
      49              prefix = sym_local;
      50          else
      51              prefix = sym_remote;
      52          end if;
      53
      54          push2(map, 0);
      55          push1(prefix);
      56          push4(sym_msmap, fm, 0, f_lab);
      57          call gtmap1;        $ generate smap(fm) label
      58          call gtpref;        $ generate  smap(fm) label
      59          call grepr;         $ and repr map: remote smap(fm) label;
      60
      61      else
      62          push2(map, 0);
      63          push4(sym_msmap, f_gen, 0, f_lab);
      64          call gtmap1;        $ generate smap(general) label
      65          call grepr;         $ and repr map: smap(general) label;
      66      end if;
      67      rpr_flag = save_rpr_flag; $ restore original repr-processing mode
      68
      69$ define 'end' label
      70      call deflab(cs_end(csp));
      71
      72      temp = cs_temp(csp); $ push result if necessary
      73
      74      if temp ^= 0 then
      75          tlast(temp) = prog_end;
      76          push1(temp);
      77      end if;
      78
      79      csp = csp-1;  $ pop cstack
      80
      81
      82      end subr gcase4;
       1 .=member gcase5
       2      subr gcase5;
       3
       4$ this routine is called at the end of each case choice. it generates
       5$ a branch to the end label.
       6
       7      call emit(q1_goto, cs_end(csp), 0, 0);
       8
       9
      10      end subr gcase5;
       1 .=member gtag1
       2      subr gtag1;
       3
       4$ this routine is called at the start of a case tag. it
       5$ allocates a label for the tag and defines it, then
       6$ saves the label on cstack.
       7
       8      size tag(ps);  $ tag label
       9
      10      tag = getlab(0);
      11      call deftag(tag);
      12
      13      cs_tag(csp) = tag;
      14
      15
      16      end subr gtag1;
       1 .=member gtag2
       2      subr gtag2;
       3
       4$ this routine is called after seeing a simple tag name.
       5$ we pop the tag value and label then do two things:
       6
       7$ 1. check that the tag is constant, then build a pair
       8$    [tag, label] and push a pointer to it onto astack.
       9
      10$ 2. increment the number of tags.
      11
      12      size nam(ps),   $ tag name
      13           lab(ps);   $ tag label
      14
      15$ get name and label
      16      pop1(nam);
      17      lab = cs_tag(csp);
      18
      19$ build pair
      20      push3(nam, lab, 1);
      21      call gtup3;
      22
      23$ increment counter for number of map elements.
      24      cs_num(csp) = cs_num(csp) + 1;
      25
      26
      27      end subr gtag2;
       1 .=member gtag3
       2      subr gtag3;
       3
       4$ this routine is called after seeing '_ name' in a case
       5$ tag. we check that nam is a constant set or tuple, then
       6$ iterate over its elements, calling 'gtag2'.
       7
       8      size nam(ps),  $ name of constant set
       9           j(ps),    $ loop index
      10           elmt(ps); $ element of constant set
      11
      12      pop1(nam);
      13
      14      if ^ is_const(nam) ! is_fprim(form(nam)) then
      15          call ermsg(20, nam);
      16
      17      else
      18          do j = 0 to vlen(nam)-1;
      19              elmt = val(vptr(nam)+j);
      20              push1(elmt);
      21              call gtag2;
      22          end do;
      23      end if;
      24
      25
      26      end subr gtag3;
       1 .=member ggoto
       2      subr ggoto;
       3
       4$ this routine processes the goto statement. for now we make
       5$ no checking for invalid gotos.
       6
       7      size lab(ps);  $ label name
       8
       9      pop1(lab);   $ get target of goto.
      10
      11      if is_decl(lab) & symtype(lab) ^= f_lab then
      12          call ermsg(21, lab);
      13      else
      14          is_decl(lab) = yes;
      15          form(lab) = f_lab;
      16          call emit(q1_goto, lab, 0, 0);
      17
      18          call deflab(getlab(0));
      19      end if;
      20
      21
      22      end subr ggoto;
       1 .=member gasrt1
       2      subr gasrt1;
       3
       4$ this routine is called at the start of every assert statement.  we
       5$ emit the branch 'if getipp('assert=1/2') = 0 then goto lab' and save
       6$ the label.
       7
       8      size lab(ps);           $ symbol table pointer for label
       9
      10      lab = getlab(0);
      11      call emit(q1_ifasrt, lab, 0, 0);
      12      push1(lab);
      13
      14      end subr gasrt1;
       1 .=member gasrt2
       2      subr gasrt2;
       3
       4$ this routine finishes the processing of 'assert  := '.
       5
       6      size lhs(ps);           $ left hand side of statement
       7      size exp(ps);           $ result of expression
       8      size var(ps);           $ internal variable for expression
       9      size lab(ps);           $ symbol table pointer for label
      10
      11
      12      pop2(exp, lhs);
      13
      14      if is_temp(exp) then
      15          var = getvar(0); call emit(q1_asn, var, exp, 0); exp = var;
      16      end if;
      17
      18      $ generate code for 'if lhs /= exp then'
      19      call gif1;
      20      push3(lhs, exp, sym_ne); call gbin;  $ emit 'lhs /= exp'
      21      call gif2;
      22
      23      $ generate code for 'then' block, i.e. when assertion failed
      24      call emit(q1_asrt, sym_false, 0, 0);  $ this assertion failed
      25      push2(lhs, exp); call gasn1;  $ emit recovery code
      26
      27      $ generate code for 'else' block, i.e. when assert succeeded
      28      call gif3;
      29      call emit(q1_asrt, sym_true, 0, 0);  $ this assertion succeeded
      30
      31      $ finish if statement
      32      call gif4;
      33
      34      pop1(lab); call deflab(lab);
      35
      36
      37      end subr gasrt2;
       1 .=member gasrt3
       2      subr gasrt3;
       3
       4$ this routine finishes the processing of 'assert '.
       5
       6      size exp(ps);           $ result of expression
       7      size lab(ps);           $ symbol table pointer for label
       8
       9      pop1(exp); call emit(q1_asrt, exp, 0, 0);
      10      pop1(lab); call deflab(lab);
      11
      12      end subr gasrt3;
       1 .=member gret1
       2      subr gret1;
       3
       4$ this routine processes 'return '. each procedure has a global
       5$ variable associated with it which is used to pass the returned value.
       6$ the name of this variable is given by 'retvar(routine)'.
       7
       8$ a return statement is treated as an assignment to the appropriate
       9$ global followed by a jump to the routines exit block.
      10
      11      size exp(ps);  $ expression being returned
      12
      13      pop1(exp);
      14
      15      call emit(q1_asn, symval(currout), exp, 0);
      16      call emit(q1_goto, exit_lab, 0, 0);
      17
      18
      19      end subr gret1;
       1 .=member gret2
       2      subr gret2;
       3
       4$ this routine processes 'return;'. this is treated as short for
       5$ 'return om;'.
       6
       7      push1(sym_om);
       8      call gret1;
       9
      10
      11      end subr gret2;
       1 .=member gexit
       2      subr gexit;
       3
       4$ this routine handles the exit statement. we make sure that we are
       5$ in a perform block then emit a branch to its exit label.
       6
       7      size lab(ps);   $ label for return point
       8
       9      if curperf = 0 then  $ not in perform block
      10          call ermsg(36, 0);
      11      else
      12          lab = val(vptr(curperf)+1);
      13          call emit(q1_goto, lab, 0, 0);
      14      end if;
      15
      16
      17      end subr gexit;
       1 .=member gcont
       2      subr gcont;
       3
smfa  16$ this routine processes the continue statement.  the top astack entry
smfa  17$ is a counter indicating which loop we should continue.  we emit a
smfa  18$ branch to its step label.
smfa  19
smfa  20      size lab(ps);           $ label to branch to
smfa  21      size n(ps);             $ number of loops to quit
smfa  22      size p(ps);             $ cstack pointer
smfa  23
smfa  24      size findlp(ps);        $ returns cstack pointer to proper loop
smfa  25
smfa  26
smfa  27      pop1(n); p = findlp(n);
smfa  28
smfa  29      if p = 0 then lab = stop_lab; else lab = cs_lstep(p); end if;
smfa  30      if (lab = 0) lab = stop_lab;
smfa  31      if (lab = stop_lab) call emit(q1_error, 0, 0, 0);
smfa  32
smfa  33      call emit(q1_goto, lab, 0, 0);
      18
      19
      20      end subr gcont;
       1 .=member gquit
       2      subr gquit;
       3
smfa  34$ this routine processes the quit statement.  the top astack entry is a
smfa  35$ counter indicating which loop we should quit.  we emit a branch to its
smfa  36$ quit label.
smfa  37
smfa  38      size lab(ps);           $ label to branch to
smfa  39      size n(ps);             $ number of loops to quit
smfa  40      size p(ps);             $ cstack pointer
smfa  41
smfa  42      size findlp(ps);        $ returns cstack pointer to proper loop
smfa  43
smfa  44
smfa  45      pop1(n); p = findlp(n);
smfa  46
smfa  47      if p = 0 then lab = stop_lab; else lab = cs_lquit(p); end if;
smfa  48      if (lab = 0) lab = stop_lab;
smfa  49      if (lab = stop_lab) call emit(q1_error, 0, 0, 0);
smfa  50
smfa  51      call emit(q1_goto, lab, 0, 0);
      17
      18
      19      end subr gquit;
       1 .=member gyield
       2      subr gyield;
       3
       4$ this routine processes the yield statement. the yield
       5$ statement is essentially a return from an 'expr' block.
       6
       7$ we begin by getting a cstack pointer to the innermost
       8$ 'expr' block; if none exists we diagnose an error.
       9$ otherwise we look up the name of the temporary for
      10$ the block, and its exit label. we then emit
      11$ 'temp = exp; go to label'.
      12
      13
      14      size j(ps),  $ loop index
      15           exp(ps);  $ temp for expression
      16$ look for 'expr' entry on cstack.
      17
      18      do j = csp to 1 by -1;
      19
      20          if cs_type(j) = cs_eblk then
      21              pop1(exp);
      22
      23              call emit(q1_asn, cs_temp(j), exp, 0);
      24              call emit(q1_goto, cs_end(j), 0, 0);
      25
      26              return;
      27          end if;
      28      end do;
      29
      30      call ermsg(24, 0);
      31
      32
      33      end subr gyield;
       1 .=member gstop
       2      subr gstop;
       3
       4$ this routine processes the stop statement. it is treated as a jump
       5$ to the routines stop label.
       6
       7      call emit(q1_goto, stop_lab, 0, 0);
       8
       9
      10      end subr gstop;
       1 .=member gdebug
       2      subr gdebug;
       3
       4$ this routine handles the debugging statement. this statement
       5$ consists of the keyword 'debug' followed by a list of names.
       6$ it is used to trigger various switches in the compiler.
       7
       8      size n(ps),   $ number of names-1
       9           j(ps),  $ loop index
      10           nam(ps);  $ debugging token
      11
      12      pop1(n);   $ number of names-1
      13
      14      do j = n to 0 by -1;
      15          nam = astack(asp-j);
      16
      17          if nam < sym_debug_min ! nam > sym_debug_max then
      18              call ermsg(47, nam);
      19
      20          elseif nam < sym_sdebug_min then  $ ignore parser option
      21              cont;
      22
      23          elseif nam > sym_sdebug_max then  $ pass to codegen
      24              call emit(q1_debug, nam, 0, 0);
      25
      26          else  $ valid debugging option
      27              go to case(nam) in sym_sdebug_min to sym_sdebug_max;
      28
      29          /case(sym_stre0)/   $ enable entry trace
      30
      31              monitor noentry;
      32              cont;
      33
      34          /case(sym_stre1)/   $ enable entry trace
      35
      36              monitor entry, limit = 10000;
      37              cont;
      38
      39          /case(sym_strs0)/   $ disable astack trace
      40
      41              trs_flag = no;
      42              cont;
      43
      44          /case(sym_strs1)/   $ enable astack trace
      45
      46              trs_flag = yes;
      47              cont;
      48
      49          /case(sym_sq1cd)/   $ q1 code dump
      50
      51              call prgdmp;
      52              cont;
      53
      54          /case(sym_sq1sd)/   $ q1 symbol table dump
      55
      56              call sdump;
      57              cont;
      58
      59          /case(sym_scstd)/   $ dump cstack
      60
      61              call csdump;
      62              cont;
      63
      64          end if;
      65      end do;
      66
      67      free_stack(n+1);
      68
      69
      70      end subr gdebug;
       1 .=member gfail
       2      subr gfail;
       3
       4$ this routine processes the fail statement.
       5
       6      call emit(q1_fail, 0, 0, 0);
       7
       8
       9      end subr gfail;
       1 .=member gscdst
       2      subr gscdst;
       3
       4$ this routine processes the succeed statement.
       5
       6      call emit(q1_succeed, 0, 0, 0);
       7
       8
       9      end subr gscdst;
       1 .=member gok
       2      subr gok;
       3
       4$ this routine processes the 'ok' operator.
       5
       6      size temp(ps);   $ temp for result
       7
       8      temp = gettmp(0);
       9
      10      tprev(temp) = prog_end;
      11
      12      call emit(q1_ok, 0, 0, 0);
      13      call emit(q1_asn, temp, sym_okval, 0);
      14
      15      tlast(temp) = prog_end;
      16      push1(temp);
      17
      18
      19      end subr gok;
       1 .=member glev
       2      subr glev;
       3
       4$ this routine processes the '.lev' operator
       5
       6      size temp(ps);   $ temp for result
       7
       8      temp = gettmp(0);
       9
      10      call emit(q1_lev, temp, 0, 0);
      11
      12      push1(temp);
      13
      14
      15      end subr glev;
       1 .=member gtrace
       2      subr gtrace;
       3
       4$ this routine processes the trace statement. for now, we
       5$ merely pop the list of options and return.
       6
       7
       8      size option(ps);        $ trace option
       9      size n(ps);             $ number of 's - 1
      10      size j(ps);             $ loop index
      11
      12
      13      pop1(n);
      14
      15      do j = 0 to n;
      16          pop1(option);
      17
      18          call emit(q1_trace, option, 0, 0);
      19      end do;
      20
      21
      22      end subr gtrace;
       1 .=member gnotrc
       2      subr gnotrc;
       3
       4$ this routine processes the 'notrace ;' statement.
       5
       6      size option(ps);        $ trace option
       7      size n(ps);             $ number of 's - 1
       8      size j(ps);             $ loop index
       9
      10
      11      pop1(n);
      12
      13      do j = 0 to n;
      14          pop1(option);
      15
      16          call emit(q1_notrace, option, 0, 0);
      17      end do;
      18
      19
      20      end subr gnotrc;
       1 .=member gasn1
       2      subr gasn1;
       3
       4$ this routine processes ' :=  ;', i.e. when it is used
       5$ as a statement.
       6
       7
       8      size lhs(ps);           $ left hand side
       9      size exp(ps);           $ result of 
      10
      11
      12      pop2(exp, lhs);   call gasn(lhs, exp, no);
      13
      14
      15      end subr gasn1;
       1 .=member gasn2
       2      subr gasn2;
       3
       4$ this routine is called after seeing ' op:=  ;', i.e.
       5$ when it is used as a statement.  we treat it as a short hand
       6$ notation for 'temp :=  op ;  := temp;'.
       7
       8
       9      size lhs(ps);           $ left hand side 
      10      size op(ps);            $ binary operator <*bin> or <*bold>
      11      size exp(ps);           $ result of 
      12      size temp(ps);          $ result of <*bin>
      13
      14
      15      pop3(exp, op, lhs);
      16
      17      push3(lhs, exp, op);    $ generate 'temp :=  op '
      18      if op < user_org then call gbin; else call gubin; end if;
      19      pop1(temp);
      20
      21$ there are 4 cases for the assignment:
      22$
      23$ 1.  is a general left hand side.  call 'gasn1' with a
      24$    copy of the code fragment for .
      25$
      26$ 2.  has an element mode.  we take the same action as in
      27$    case 1 since we need the assignment to convert the result.
      28$
      29$ 3.  is a simple variable with write access.  emit a simple
      30$    assignment.
      31$
      32$ 4.  is read-only.  generate a diagnostic.
      33
      34      if is_temp(lhs) ! ft_type(form(lhs)) = f_elmt then
      35          push2(copy(lhs), temp);   call gasn1;
      36
      37      elseif is_write(lhs) ! is_param(lhs) then
      38          push2(lhs, temp);         call gasn1;
      39
      40      else
      41          call ermsg(19, lhs);
      42      end if;
      43
      44
      45      end subr gasn2;
       1 .=member gasn3
       2      subr gasn3;
       3
       4$ this routine processes ' := ', i.e. when itis used
       5$ as an expression.  there are three possibilities:
       6$
       7$ 1. both lhs and rhs are expressions:  we emit
       8$        internal := rhs
       9$        lhs      := internal
      10$        result   := internal
      11$    and push result.
      12$
      13$ 2. lhs is a name: emit
      14$        lhs      := rhs
      15$        result   := lhs
      16$    and push result.
      17$
      18$ 3. rhs is a name: emit
      19$        lhs      := rhs
      20$        result   := rhs
      21$    and push result.
      22
      23
      24      size lhs(ps);           $ left hand side
      25      size rhs(ps);           $ right hand side
      26      size var(ps);           $ 'internal' above
      27      size result(ps);        $ result above
      28
      29
      30      pop2(rhs, lhs);
      31
      32      result = gettmp(0);
      33
      34      if is_temp(rhs) then
      35          tprev(result) = tprev(rhs);
      36      else
      37          tprev(result) = prog_end;
      38      end if;
      39
      40      if is_temp(lhs) & is_temp(rhs) then
      41          var = getvar(0);
      42
      43          call emit(q1_asn,    var,  rhs,    0);
      44          push2(lhs, var);   call gasn1;
      45          call emit(q1_asn, result,  var,    0);
      46
      47      elseif ^ is_temp(lhs) then
      48          call emit(q1_asn,    lhs,  rhs,    0);
      49          call emit(q1_asn, result,  lhs,    0);
      50
      51      else
      52          push2(lhs, rhs);   call gasn1;
      53          call emit(q1_asn, result,  rhs,    0);
      54      end if;
      55
      56      tlast(result) = prog_end;
      57      push1(result);
      58
      59
      60      end subr gasn3;
       1 .=member gasn4
       2      subr gasn4;
       3
       4$ this routine is called after seeing ' op:= ', i.e.
       5$ when it is used as an expression.  we treat it as a short hand
       6$ notation for 'temp :=  op ;  := temp;'.
       7$
       8$ this routine is identical to 'gasn2', except that we call 'gasn3'
       9$ for the final assignment.
      10
      11
      12      size lhs(ps);           $ left hand side 
      13      size op(ps);            $ binary operator <*bin> or <*bold>
      14      size exp(ps);           $ result of 
      15      size temp(ps);          $ result of <*bin>
      16
      17
      18      pop3(exp, op, lhs);
      19
      20      push3(lhs, exp, op);    $ generate 'temp :=  op '
      21      if op < user_org then call gbin; else call gubin; end if;
      22      pop1(temp);
      23
      24      if is_temp(lhs) ! ft_type(form(lhs)) = f_elmt then
      25          push2(copy(lhs), temp);   call gasn3;
      26
      27      elseif is_write(lhs) ! is_param(lhs) then
      28          push2(lhs, temp);         call gasn3;
      29
      30      else
      31          call ermsg(19, lhs);
      32      end if;
      33
      34
      35      end subr gasn4;
       1 .=member gfrom1
       2      subr gfrom1;
       3
       4$ this routine processes 'a1 <*from> a2;'.
       5
       6$ n.b. 'a1' is an output, while 'a2' is both an input and an output.
       7$      we therefore might have to generate two sinister assignments.
       8
       9
      10      size op(ps);            $ operator
      11      size a1(ps);            $ left operand
      12      size a2(ps);            $ right operand
      13
      14      size t1(ps), t2(ps);    $ possible copies of operands
      15
      16
      17      pop3(a2, op, a1);
      18
      19      if is_temp(a1) then
      20          t1 = getvar(0);
      21      else
      22          if (^is_write(a1) & ^is_param(a1)) call ermsg(19, a1);
      23
      24          t1 = a1;
      25      end if;
      26
      27      if is_temp(a2) ! ft_type(form(a2)) = f_elmt then
      28          t2 = gettmp(0);   tprev(t2) = tprev(a2);
      29          call emit(q1_asn, t2, a2, 0);
      30      else
      31          if (^is_write(a2) & ^is_param(a2)) call ermsg(19, a2);
      32
      33          t2 = a2;
      34      end if;
      35
      36      call emit(opmap(op), t1, t2, 0);
      37
      38      if (t1 ^= a1) call gasn(     a1 , t1, no);
      39      if (t2 ^= a2) call gasn(copy(a2), t2, no);
      40
      41
      42      end subr gfrom1;
       1 .=member gfrom2
       2      subr gfrom2;
       3
       4$ this routine processes 'result := a1 <*from> a2'.
       5
       6$ n.b. 'a1' is an output, while 'a2' is both an input and an output.
       7$      we therefore might have to generate two sinister assignments.
       8
       9
      10      size op(ps);            $ operator
      11      size a1(ps);            $ left operand
      12      size a2(ps);            $ right operand
      13
      14      size result(ps);        $ temporary for result of expression
      15      size t1(ps), t2(ps);    $ possible copies of operands
      16
      17
      18      pop3(a2, op, a1);
      19
      20      result = gettmp(0);   tprev(result) = prog_end;
      21
      22      if is_temp(a1) then
      23          t1 = getvar(0);
      24      else
      25          if (^is_write(a1) & ^is_param(a1)) call ermsg(19, a1);
      26
      27          t1 = a1;
      28      end if;
      29
      30      if is_temp(a2) ! ft_type(form(a2)) = f_elmt then
      31          t2 = gettmp(0);
      32          call emit(q1_asn, t2, a2, 0);
      33      else
      34          if (^is_write(a2) & ^is_param(a2)) call ermsg(19, a2);
      35
      36          t2 = a2;
      37      end if;
      38
      39      call emit(opmap(op), t1, t2, 0);
      40
      41      if (t1 ^= a1) call gasn(     a1 , t1, no);
      42      if (t2 ^= a2) call gasn(copy(a2), t2, no);
      43
      44      call emit(q1_asn, result, t1, 0);   tlast(result) = prog_end;
      45      push1(result);
      46
      47
      48      end subr gfrom2;
       1 .=member gbin
       2      subr gbin;
       3
       4$ this routine proceses 'result = a1 <*bin> a2'.
       5
       6
       7      size op(ps);            $ (binary) operator
       8      size a1(ps);            $ left operand
       9      size a2(ps);            $ right operand
      10
smfb 323      size lab(ps);           $ label in logical expression
smfb 324      size bool1(1);          $ 'left operand is result of boolean'
smfb 325      size true1(ps);         $ true list for left operand
smfb 326      size false1(ps);        $ false list for left operand
smfb 327      size bool2(1);          $ 'right operand is result of boolean'
smfb 328      size true2(ps);         $ true list for right operand
smfb 329      size false2(ps);        $ false list for right operand
      11      size t1(ps);            $ internal variable for a1
      12      size t2(ps);            $ result of test for query
      13      size prev(ps);          $ program end at start of routine
smfb 330      size result(ps);        $ result of operation
smfb 331      size success(1);        $ indicates successful constant folding
      16
      17
      18      pop3(op, a2, a1);
      19
smfb 332      if op = sym_and ! op = sym_or ! op = sym_impl then
smfb 333
smfb 334          $ first determine whether any of the inputs is the result of a
smfb 335          $ boolean operation.  we can simplify the code if it is.
smfb 336          if is_temp(a2) = yes & bsp >= 1 then
smfb 337              if a2 = bs_temp(bsp) then
smfb 338                  true2 = bs_true(bsp); false2 = bs_false(bsp);
smfb 339                  bool2 = yes; bsp = bsp - 1;
smfb 340              else
smfb 341                  bool2 = no;
smfb 342              end if;
smfb 343          else
smfb 344              bool2 = no;
smfb 345          end if;
smfb 346
smfb 347          if is_temp(a1) = yes & bsp >= 1 then
smfb 348              if a1 = bs_temp(bsp) then
smfb 349                  true1 = bs_true(bsp); false1 = bs_false(bsp);
smfb 350                  bool1 = yes; bsp = bsp - 1;
smfb 351              else
smfb 352                  bool1 = no;
smfb 353              end if;
smfb 354          else
smfb 355              bool1 = no;
smfb 356          end if;
smfb 357
smfb 358          lab = getlab(0);
smfb 359          result = gettmp(0); tprev(result) = prog_end;
smfd  10          is_back(result) = yes;
smfb 360
smfb 361          if op = sym_and then
smfb 362
smfb 363              call emit(q1_asn,   result, sym_false, 0);
smfb 364
smfb 365              prev = prog_end; call movblk(tprev(a1), tlast(a1), prev);
smfb 366              call gbool(q1_bifnot, a1, bool1, true1, false1, lab);
smfb 367
smfb 368              prev = prog_end; call movblk(tprev(a2), tlast(a2), prev);
smfb 369              call gbool(q1_bifnot, a2, bool2, true2, false2, lab);
smfb 370
smfb 371              call emit(q1_asn,   result,  sym_true, 0);
smfb 372
smfb 373              countup(bsp, bstack_lim, 'bstack'); bstack(bsp) = 0;
smfb 374              bs_temp(bsp) = result; bs_false(bsp) = lab;
smfb 375
smfb 376          elseif op = sym_or then
smfb 377
smfb 378              call emit(q1_asn,   result,  sym_true, 0);
smfb 379
smfb 380              prev = prog_end; call movblk(tprev(a1), tlast(a1), prev);
smfb 381              call gbool(q1_bif, a1, bool1, false1, true1, lab);
smfb 382
smfb 383              prev = prog_end; call movblk(tprev(a2), tlast(a2), prev);
smfb 384              call gbool(q1_bif, a2, bool2, false2, true2, lab);
smfb 385
smfb 386              call emit(q1_asn,   result, sym_false, 0);
smfb 387
smfb 388              countup(bsp, bstack_lim, 'bstack'); bstack(bsp) = 0;
smfb 389              bs_temp(bsp) = result; bs_true(bsp) = lab;
smfb 390
smfb 391          else    $ op = sym_impl
smfb 392
smfb 393              call emit(q1_asn,   result,  sym_true, 0);
smfb 394
smfb 395              prev = prog_end; call movblk(tprev(a1), tlast(a1), prev);
smfb 396              call gbool(q1_bifnot, a1, bool1, true1, false1, lab);
smfb 397
smfb 398              prev = prog_end; call movblk(tprev(a2), tlast(a2), prev);
smfb 399              call gbool(q1_bif, a2, bool2, false2, true2, lab);
smfb 400
smfb 401              call emit(q1_asn,   result, sym_false, 0);
smfb 402
smfb 403              countup(bsp, bstack_lim, 'bstack'); bstack(bsp) = 0;
smfb 404              bs_temp(bsp) = result; bs_true(bsp) = lab;
smfb 405          end if;
smfb 406
smfb 407          call deflab(lab);
smfb 408
smfb 409          tlast(result) = prog_end; push1(result);
      31
      32      elseif op = sym_query then
      33          $ 'result := if (t2 := (t1 := a1) /= om) then t1 else a2 end'
      34          if is_temp(a1) then
      35              t1 = getvar(0);   prev = tprev(a1);
      36              call emit(q1_asn, t1, a1, 0);
      37          else
      38              t1 = a1;   prev = prog_end;
      39          end if;
      40          t2 = gettmp(0);
      41          call emit(q1_ne, t2, t1, sym_om);   tprev(t2) = prev;
      42          call gcond(t2, t1, a2);
      43
      44      else
      45          $ try to fold the instruction
      46          call fldbin(op, a1, a2, success);   if (success) return;
      47
      48          $ emit the necessary code.  if the operator is >, <=, or
      49          $ subset, we begin by permuting the operands.
      50
      51          if op = sym_gt ! op = sym_le  ! op = sym_subset then
      52              swap(a1, a2);
      53          end if;
      54
      55          result = gettmp(0);
      56          call emit(opmap(op), result, a1, a2);
      57          push1(result);
      58
      59      end if;
      60
      61
      62      end subr gbin;
       1 .=member gbool
       2      subr gbool(opc, a1, bool, l1, l2, lab);
       3$
       4$ this routine modifies the code generated for the boolean result a1
       5$ when a1 is used in an conditional branch.
       6$
       7      size opc(ps);           $ opcode for conditional branch
       8      size a1(ps);            $ symtab pointer for operand
       9      size bool(1);           $ indicates that a1 is result of boolean
      10      size l1(ps), l2(ps);    $ symtab pointers for true/false labels
      11      size lab(ps);           $ symtab pointer for new label
      12
      13      size p(ps);             $ codetab pointer to current instruction
      14      size op(ps);            $ opcode of current instruction
      15
      16
      17      if trs_flag then  $ provide trace
      18          put ,skip
      19              ,'entering gbool with ' :opc:a1:bool:l1:l2:lab,nil ,skip;
      20          call prgdmp;
      21      end if;
      22
      23      if bool = no then
      24          call emit(opc, a1, lab, 0);
      25          return;
      26      end if;
      27
      28      p = next(tprev(a1));  $ iterate over code fragment
      29      while 1;
      30          if (p = 0) quit while 1;
      31
      32          op = opcode(p);
      33          if op = q1_asn & arg1(p) = a1 then
      34              if arg2(p) = sym_true ! arg2(p) = sym_false then
      35                  opcode(p) = q1_noop;  $ delete instruction
      36              else
      37                  call ermsg(0, a1);
      38              end if;
      39
      40          elseif (op = q1_bif ! op = q1_bifnot) & arg2(p) = l2 then
      41              arg2(p) = lab;
      42
      43          elseif op = q1_goto & arg1(p) = l2 then
      44              arg1(p) = lab;
      45
      46          elseif op = q1_label then
      47              if arg1(p) = l1 then
      48                  opcode(p) = q1_noop;  $ 'undefine' label
      49                  is_seen(l1) = no; vptr(l1) = 0; vlen(l1) = 0;
      50              elseif arg1(p) = l2 then
      51                  opcode(p) = q1_noop;
      52                  symtab(l2) = 0;  $ drop dead label
      53              end if;
      54          end if;
      55
      56          if (p = tlast(a1)) quit while 1;
      57
      58          p = next(p);
      59      end while 1;
      60
      61      symtab(a1) = 0;  $ drop dead temporary
      62
      63      if l1 ^= 0 then
      64          call emit(q1_goto, lab, 0, 0);
      65          call deflab(l1);
      66      end if;
      67
      68
      69      end subr gbool;
       1 .=member gubin
       2      subr gubin;
       3
       4$ this routine processes calls to user defined binary operators. we
       5$ reorder the arguments on astack then call gfcall.
       6
       7      size op(ps),   $ operator
       8           a1(ps),   $ first argument
       9           a2(ps);   $ second argument
      10
      11      pop3(op, a2, a1);
      12      push3(op, a1, a2);
      13
      14      call gfcall(2);
      15
      16
      17      end subr gubin;
       1 .=member gun
       2      subr gun;
       3
       4$ this routine processes unary operators. we pop the operand and
       5$ operator symbol from the stack then emit an instruction.
       6
       7      size op(ps),  $ name of operator
       8           opc(ps),    $ q1 opcode
       9           a1(ps),  $ operand
      10           temp(ps),  $ result
      11           success(1); $ flags successful folding
smfb 410      size p(ps);             $ codetab pointer
      12
      13      pop2(op, a1);
      14
      15      if op = sym_plus then   $ treat as noop
      16          push1(a1);
      17          return;
      18      end if;
      19
      20$ try to fold instruction
      21      call foldun(op, a1, success);
      22      if (success) return;
smfb 411
smfb 412      if op = sym_not & is_temp(a1) = yes & bsp >= 1 then
smfb 413          if a1 = bs_temp(bsp) then
smfb 414
smfb 415              p = next(tprev(a1));  $ iterate over code fragment
smfb 416              while 1;
smfb 417                  if (p = 0) quit while 1;
smfb 418
smfb 419                  if opcode(p) = q1_asn & arg1(p) = a1 then
smfb 420                      if arg2(p) = sym_true then
smfb 421                          arg2(p) = sym_false;
smfb 422                      elseif arg2(p) = sym_false then
smfb 423                          arg2(p) = sym_true;
smfb 424                      else
smfb 425                          call ermsg(0, a1);
smfb 426                      end if;
smfb 427                  end if;
smfb 428
smfb 429                  if (p = tlast(a1)) quit while 1;
smfb 430
smfb 431                  p = next(p);
smfb 432              end while 1;
smfb 433
smfb 434              swap(bs_true(bsp), bs_false(bsp));
smfb 435              push1(a1);
smfb 436
smfb 437              return;
smfb 438          end if;
smfb 439      end if;
      23
      24      temp = gettmp(0);       $ temporary for result
      25
      26      if op = sym_minus then
      27          opc = q1_umin;
      28      else
      29          opc = opmap(op);
      30      end if;
      31
      32      call emit(opc, temp, a1, 0);
      33
      34      push1(temp);
      35
      36
      37      end subr gun;
       1 .=member guun
       2      subr guun;
       3
       4$ this routine processes user defined unary operators. it is
       5$ similar to 'gubin'.
       6
       7      size op(ps),  $ operator
       8           arg(ps); $ argument
       9
      10      pop2(op, arg);
      11      push2(op, arg);
      12
      13      call gfcall(1);
      14
      15
      16      end subr guun;
       1 .=member gnewat
       2      subr gnewat;
       3
       4$ this routine processes 'newat'.
       5
       6      size t(ps);  $ temp for result
       7
       8      t = gettmp(0);
       9      call emit(q1_newat, t, 0, 0);
      10
      11      push1(t);
      12
      13
      14      end subr gnewat;
       1 .=member gtime
       2      subr gtime;
       3
       4$ this routine processes the time operator
       5
       6size temp(ps);  $ temp for result
       7
       8      temp = gettmp(0);
       9      call emit(q1_time, temp, 0, 0);
      10
      11      push1(temp);
      12
      13
      14      end subr gtime;
       1 .=member gdate
       2      subr gdate;
       3
       4$ this routine processes the date operator
       5
       6size temp(ps);  $ temp for result
       7
       8      temp = gettmp(0);
       9      call emit(q1_date, temp, 0, 0);
      10
      11      push1(temp);
      12
      13
      14      end subr gdate;
       1 .=member gna
       2      subr gna;
       3
       4$ this routine proceses the 'number of arguments' operator
       5
       6      size t(ps);   $ temp for result
       7
       8      t = gettmp(0);
       9      call emit(q1_na, t, 0, 0);
      10
      11      push1(t);
      12
      13
      14      end subr gna;
       1 .=member gdash
       2      subr gdash;
       3
       4$ this routine is called after seeing the expression '-'.
       5
       6$ according to the definition of setl, the dash can only occur
       7$ in two contexts:
       8
       9$ 1. in a multiple assignment '[a, -] := [1, 2]'.
      10$ 2. in an argument list 'y := f(x, -)'.
      11
      12$ it is extremely expensive to check that the dash is not used anywhere
      13$ else. instead we allow it to be used in any expression and treat it
      14$ as a synonym for omega.
      15
      16$ at this point we simply push omega. if an omega appears in the left
      17$ hand side of a multiple assignment we assume that it is a substitute
      18$ for a dash and ignore the assignment.
      19
      20      push1(sym_om);
      21
      22
      23      end subr gdash;
       1 .=member geof
       2      subr geof;
       3
       4$ this routine handles the 'eof' operator.  we simply push sym_eof
       5$ then handle it like a function call with no parameters.
       6
       7
       8      push1(sym_eof);   call gfcall(0);
       9
      10
      11      end subr geof;
       1 .=member gifx1
       2      subr gifx1;
       3
       4$ this routine is called at the start of a conditional expression.
       5$ conditional expressions are treated like if-statements, with
       6$ a few extra generators to assign the value of each alternative
       7$ to a temporary.
       8
       9$ at this point we have already built a cstack entry. we allocate
      10$ a temporary for the result, set its 'tprev' field to point to
      11$ the last instruction, and save a pointer to it on cstack.
      12
      13      size temp(ps);  $ temporary for result
      14
      15      temp = gettmp(0);
      16      tprev(temp) = prog_end;
      17
      18      cs_temp(csp) = temp;
      19
      20
      21      end subr gifx1;
       1 .=member gifx2
       2      subr gifx2;
       3
       4$ this routine is called after we have seen one of the alternatives
       5$ in a conditional expression. we assign it to the temporary which
       6$ we have saved on cstack.
       7
       8      size exp(ps);  $ result of expression
       9
      10      pop1(exp);
      11
      12      call emit(q1_asn, cs_temp(csp), exp, 0);
      13
      14
      15      end subr gifx2;
       1 .=member gcond
       2      subr gcond(e1, e2, e3);
       3
       4$ this routine emits 'if e1 then e2 else e3'. it does this by
       5$ faking the proper sequence of calls to the 'gif' routines.
       6
       7$ note that before using any of the expressions e1, etc. we
       8$ must move them to the end of the program.
       9
      10      size e1(ps),  $ first expression
      11           e2(ps),  $ second expression
      12           e3(ps);  $ third expression
      13
      14      size targ(ps);  $ target of move
      15
      16      call gif1;   $ open if-expression
      17      call gifx1;
      18
      19$ emit 'e1 then'
      20      if is_temp(e1) then
      21          targ = prog_end;
      22          call movblk(tprev(e1), tlast(e1), targ);
      23
      24          tprev(cs_temp(csp)) = tprev(e1);
      25      end if;
      26
      27      push1(e1);
      28      call gif2;
      29
      30$ emit 'e2 else'
      31      if is_temp(e2) then
      32          targ = prog_end;
      33          call movblk(tprev(e2), tlast(e2), targ);
      34      end if;
      35
      36      push1(e2);
      37      call gifx2;
      38      call gif3;
      39
      40$ emit 'e3 end'
      41      if is_temp(e3) then
      42          targ = prog_end;
      43          call movblk(tprev(e3), tlast(e3), targ);
      44      end if;
      45
      46      push1(e3);
      47      call gifx2;
      48      call gif4;
      49
      50
      51      end subr gcond;
       1 .=member gof
       2      subr gof;
       3
       4$ this is the top level routine for processing 't = f(x1 ... xn)'.
       5$ we call lower level routines to handle two cases:
       6
       7$ 1. 'f' is known to be a procedure
       8
       9$ 2. 'f' is a procedure
      10
      11      size n(ps),   $ number of arguments
      12           f(ps);   $ function/map name
      13
      14$ we begin by popping the number of arguments, then getting the
      15$ the name of the map.
      16
      17      pop1(n);   $ no. of arguments-1
      18
      19      f = astack(asp-n-1);
      20
      21      if is_proc(f) then
      22          call gfcall(n+1);
      23      else
      24          call gof1(n);
      25      end if;
      26
      27
      28      end subr gof;
       1 .=member gof1
       2      subr gof1(n);
       3
       4$ this routine processes 'result := map(indx)'.  at this point we
       5$ know that we actually have to generate a map retrieval and not a
       6$ function call.
       7
       8
       9      size n(ps);             $ number of indices minus one
      10
      11      size map(ps);           $ symbol table pointer for map
      12      size indx(ps);          $ dto. for index
      13      size result(ps);        $ result of map retrieval
      14
      15
      16      if n > 0 then           $ form index tuple
      17          push1(n);   call gtup3;
      18      end if;
      19
      20      pop2(indx, map);   call chkvar(map);   result = gettmp(0);
      21      call emit(q1_of, result, map, indx);
      22      push1(result);
      23
      24
      25      end subr gof1;
       1 .=member gfcall
       2      subr gfcall(n);
       3
       4$ this routine emits an n-argument function call.
       5
       6$ setl makes no distinction between functions and subroutines.
       7$ instead, every procedure returns a value. this value may be
       8$ omega, and may be disgarded by the caller. the value is returned
       9$ by assigning it to the name of the procedure.
      10
      11$ a function call is identical to a subroutine call except that it saves
      12$ the returned value in a temporary. we begin by allocating a temporary
      13$ and setting its tprev field. we then emit a subroutine call and assign
      14$ the returned value to the temporary.
      15
      16      size n(ps);   $ number of arguments
      17
      18      size j(ps),    $ loop index
      19           rout(ps),  $ routine name
      20           arg(ps),  $ argument name
      21           t(ps),  $ result of call
      22           prev(ps);   $ value of tprev
      23
      24$ allocate a temporary then set 'prev'
      25      t = gettmp(0);
      26
      27      prev = 0;
      28
      29      do j = 1 to n;
      30          arg = astack(asp-n+j);
      31
      32          if is_temp(arg) then
      33              prev = tprev(arg);
      34              quit;
      35          end if;
      36      end do;
      37
      38      if (prev = 0) prev = prog_end;
      39      tprev(t) = prev;
      40
      41$ save routine name, then emit call and assignment.
      42      rout = astack(asp-n);
      43
      44      call gcall(n);
      45      call emit(q1_asn, t, symval(rout), 0);
      46
      47      tlast(t) = prog_end;
      48      push1(t);
      49
      50
      51      end subr gfcall;
       1 .=member gofa
       2      subr gofa;
       3
       4$ this routine processes 'result := map<>'.
       5
       6
       7      size map(ps);           $ symbol table pointer for map
       8      size indx(ps);          $ dto. for index
       9      size n(ps);             $ number of indices minus one
      10      size result(ps);        $ result of map retrieval
      11
      12
      13      if astack(asp) > 0 then $ form index tuple
      14          call gtup3;
      15      else
      16          pop1(n);
      17      end if;
      18
      19      pop2(indx, map);   call chkvar(map);   result = gettmp(0);
      20      call emit(q1_ofa, result, map, indx);
      21      push1(result);
      22
      23
      24      end subr gofa;
       1 .=member goft
       2      fnct goft(tuple, indx);
       3
       4$ this routine emits 't = tuple(indx)' and returns a symbol table
       5$ pointer to 't'.
       6
       7$ note that 'indx' is not a symbol table pointer, but an integer.
       8
       9      size tuple(ps),   $ symtab pointer for tuple
      10           indx(ps);    $ value of index
      11
      12      size goft(ps);  $ temporay returned
      13
      14
      15      push2(tuple, getint(indx));   call gof1(0);   pop1(goft);
      16
      17
      18      end fnct goft;
       1 .=member gsub1
       2      subr gsub1;
       3
       4$ this routine emits 't = f(i ... j)'.
       5
       6
       7      size t(ps),             $ result
       8           f(ps),             $ tuple
       9           i(ps),             $ origin
      10           j(ps);             $ length
      11
      12      size a(ps);             $ array of arguments
      13      dims a(4);
      14
      15
      16      pop3(j, i, f);
      17
      18      t = gettmp(0);
      19
      20      a(1) = t;               $ pack arguments into 'a'
      21      a(2) = f;
      22      a(3) = i;
      23      a(4) = j;
      24
      25      call emitn(q1_subst, a, 4);
      26
      27      push1(t);
      28
      29
      30      end subr gsub1;
       1 .=member gsub2
       2      subr gsub2;
       3
       4$ this routine emits 't = f(i:)'.
       5
       6
       7      size t(ps),  $ result
       8           f(ps),  $ tuple
       9           i(ps);  $ origin
      10      pop2(i, f);
      11
      12      t = gettmp(0);
      13      call emit(q1_end, t, f, i);
      14
      15      push1(t);
      16
      17
      18      end subr gsub2;
       1 .=member gfnp
       2      subr gfnp;
       3
       4$ this routine processes 't = f()'.
       5
       6      call gfcall(0);
       7
       8
       9      end subr gfnp;
       1 .=member gquant
       2      subr gquant;
       3
       4$ this routine is called at the start of a quantifier.  the basic
       5$ form of a quantifier is 'exists x in s st c(x)' and is implemented
       6$ as:
       7$
       8$     expr
       9$         t := false;
      10$
      11$         (forall x in s st c(x)) t := true; quit forall; end;
      12$
      13$         yield t;
      14$     end
      15$
      16$ we allocate a temporary 't' and initialize it to false.  we then
      17$ push it onto astack so we can refer to it later.
      18$
      19$ note that the temporary must always be backtracked.
      20
      21
      22      size t(ps);             $ temporary for result
      23
      24
      25      t = gettmp(0);   tprev(t) = prog_end;   is_back(t) = yes;
      26
      27      call emit(q1_asn, t, sym_false, 0);
      28
      29      push1(t);
      30
      31
      32      end subr gquant;
       1 .=member gexist
       2      subr gexist;
       3
       4$ this routine is called after processing an entire existential
       5$ quantifier.
       6
       7
       8      size prev(ps);          $ start of loop body
       9      size last(ps);          $ end of loop body
      10      size result(ps);        $ result of quantifier
      11
      12
      13      prev = prog_end;        $ save pointer to start of loop body
      14
      15      pop1(result);      call emit(q1_asn, result, sym_true, 0);
      16      push1(1);          call gquit;
      17      last = prog_end;   call gbody(prev, last);
      18      call endlp;
      19
      20      tlast(result) = prog_end;   push1(result);
      21
      22
      23      end subr gexist;
       1 .=member gnexst
       2      subr gnexst;
       3$
       4$ this routine is called after seeing a complete negated existential
       5$ quantifier
       6$       'notexists x in s st c(x)'
       7$ we treat is as
       8$       'not exists x in s st c(x)'
       9$
      10      call gexist;
      11
      12      $ now complement the result
      13      push1(sym_not);   call gun;
      14
      15
      16      end subr gnexst;
       1 .=member gunivq
       2      subr gunivq;
       3
       4$ the universal quantifier
       5$     'forall x in s st c(x)'
       6$ is treated as
       7$     'not exists x in s st not c(x)'
       8$
       9$ at this point we have already emitted the opener for the
      10$ existential quantifier.  we merely negate the condition, emit the
      11$ body of the existential quantifier, and finally negate the result.
smfe  10
smfe  11      push1(sym_not);  call gun;  call gwhere;
      26
      27      call gexist;
      28
      29      $ now compliment the result
      30      push1(sym_not);   call gun;
      31
      32
      33      end subr gunivq;
       1 .=member geblk1
       2      subr geblk1;
       3
       4$ this routine is called at the start of an expression block.
       5$ it builds a new cstack entry, then obtains a temporary for
       6$ the result and a label for the end of the block.
       7
       8
       9      size t(ps);   $ temp for result
      10
      11
      12      countup(csp, cstack_lim, 'cstack');
      13      cstack(csp) = 0;
      14      cs_type(csp) = cs_eblk;
      15
      16      t = gettmp(0);
      17      tprev(t) = prog_end;
      18
      19      cs_temp(csp) = t;
      20      cs_end(csp) = getlab(0);
      21
      22
      23      end subr geblk1;
       1 .=member geblk2
       2      subr geblk2;
       3
       4$ this routine is called at the end of an expression block. we
       5$ begin by defining the label for the block. we then push the
       6$ result of the block onto astack and pop cstack.
       7
       8
       9      size t(ps);   $ temp for result
      10
      11
      12      call deflab(cs_end(csp));
      13
      14$ push result and set tlast.
      15
      16      t = cs_temp(csp);
      17      tlast(t) = prog_end;
      18      push1(t);
      19
      20      csp = csp-1;  $ pop cstack
      21
      22
      23      end subr geblk2;
       1 .=member gcomp1
       2      subr gcomp1;
       3
       4$ this routine is called at the start of a compound operator.
       5$ the compound operator 'op/ s' is treated as:
       6
       7$    expr
       8$        t1 = true;
       9
      10$        (! t3 _ s)
      11$            if t1 then     $ first time through loop
      12$                t1 := false;
      13$                t2 := t3;
      14$            else           $ all other iterations
      15$                t2 := t2 op t3;
      16$            end if;
      17$        end !;
      18
      19$        yield t2;
      20$    end
      21
      22$ at this point we allocate the two temporaries and push pointers
      23$ to them onto astack. we also emit code to initialize t1.
      24
      25      size t1(ps),   $ temporaries
      26           t2(ps);
      27
      28      call geblk1;  $ open expression block
      29
      30      t1 = getvar(0);
      31      t2 = getvar(0);
      32
      33      call emit(q1_asn, t1, sym_true, 0);
      34      call emit(q1_asn, t2, sym_om,   0);
      35
      36      push2(t1, t2);   $ save temporary names on stack
      37
      38
      39      end subr gcomp1;
       1 .=member gcomp2
       2      subr gcomp2;
       3
       4$ this routine is called after seeing a compound operator of the
       5$ form 'op/ [ exp: x _ s]'. this would seem to imply a double
       6$ iteration, one to build the tuple and one for the compond operator.
       7$ in fact we can do it in a single iteration, and avoid building the
       8$ tuple.
       9
      10$ at this point we have already emitted the loop over s and pushed
      11$ a pointer to 'exp' onto astack.
      12
      13$ at this point the top astack entries are:
      14
      15$ 1. a pointer to 'exp'. this corresponds to 't3' in gcomp1, above.
      16$ 2. a pointer to 't2' (see gcomp1)
      17$ 3. a pointer to 't1' (see gcomp1)
      18
      19$ we pop the arguments, then emit the 'if' statement given in
      20$ gcomp1.
      21
      22      size t1(ps),   $ temporaries in above setl code
      23           t2(ps),
      24           t3(ps),
      25           exp(ps);
      26
      27      size t(ps);  $ result of 'op'
      28
      29      size prev(ps),   $ start of body
      30           last(ps),   $ end of body
      31           op(ps);     $ compound operator
      32
      33      pop3(exp, t2, t1);
      34
      35      prev = prog_end;   $ save pointer to start of loop body
      36
      37      if is_temp(exp) then
      38          call movblk(tprev(exp), tlast(exp), prev);
      39          prev = tprev(exp);
      40
      41          t3 = getvar(0);
      42          call emit(q1_asn, t3, exp, 0);
      43
      44      else
      45          t3 = exp;
      46      end if;
      47
      48      call gif1;   $ emit 'if t1 then'
      49
      50      push1(t1);
      51      call gif2;
      52
      53$ emit 'then' block.
      54      call emit(q1_asn, t1, sym_false, 0);
      55      call emit(q1_asn, t2, t3,        0);
      56
      57      call gif3;   $ emit else block
      58
      59$ emit 't2 op t3'. begin by popping 'op' and seeing whether it is a
      60$ system operator.
      61
      62      pop1(op);
      63      push3(t2, t3, op);
      64
      65      if op <= sym_maximum then call gbin; else call gubin; end if;
      66
      67      pop1(t);
      68      call emit(q1_asn, t2, t, 0);
      69
      70      call gif4;   $ emit 'end if'
      71
      72$ install loop body
      73      last = prog_end;
      74
      75      call gbody(prev, last);
      76      call endlp;
      77
      78$ close expr block
      79      push1(t2);
      80      call gyield;
      81      call geblk2;
      82
      83
      84      end subr gcomp2;
       1 .=member gcomp3
       2      subr gcomp3;
       3
       4$ this routine is called after seeing a general compound operator
       5$ 'op/ s'. it is similar to gcomp2, above.
       6
       7$ we begin by popping t1 and t2, then generating an iterator over
       8$ s.
       9
      10      size s(ps),   $ set being iterated over
      11           t1(ps),  $ temporaries above
      12           t2(ps),
      13           t3(ps);
      14
      15      size t(ps);  $ result of 'op'
      16
      17      size prev(ps),  $ start of body
      18           last(ps),  $ end of body
      19           op(ps);    $ compound operator
      20
      21      size gtiter(ps);        $ returns iterator
      22
      23      pop3(s, t2, t1);
      24      t3 = gtiter(s, no);
      25
      26$ save pointer to start of body, then open 'if' statement.
      27      prev = prog_end;
      28
      29      call gif1;
      30      push1(t1);
      31      call gif2;
      32
      33$ emit 'then' block.
      34      call emit(q1_asn, t1, sym_false, 0);
      35      call emit(q1_asn, t2, t3,        0);
      36
      37      call gif3;   $ emit else block
      38
      39$ emit 't2 op t3'. begin by popping 'op' and seeing whether it is a
      40$ system operator.
      41
      42      pop1(op);
      43      push3(t2, t3, op);
      44
      45      if op <= sym_maximum then call gbin; else call gubin; end if;
      46
      47      pop1(t);
      48      call emit(q1_asn, t2, t, 0);
      49
      50      call gif4;   $ emit 'end if'
      51
      52$ install loop body
      53      last = prog_end;
      54
      55      call gbody(prev, last);
      56      call endlp;
      57
      58$ close expr block
      59      push1(t2);
      60      call gyield;
      61      call geblk2;
      62
      63
      64      end subr gcomp3;
       1 .=member gcomp4
       2      subr gcomp4;
       3
       4$ this routine is called at the start of a compound operator.
       5$ the compound operator 'result := a1 op/ a2' is treated as:
       6$
       7$    t1 = a1;
       8$
       9$    (forall t2 in a2)
      10$       temp := t1 op t2; t1 := temp;
      11$    end forall;
      12$
      13$    result := t1;
      14$
      15$ at this point we allocate an internal variable for t1, set it to
      16$ a1, and save it on the stack.  we also allocate the temporary
      17$ for the final result, and save it.
      18
      19
      20      size a1(ps);            $ left operand
      21      size op(ps);            $ (binary) operator
      22      size t1(ps);            $ copy of left operand
      23      size result(ps);        $ temporary for result
      24
      25
      26      pop2(op, a1);   t1 = getvar(0);   result = gettmp(0);
      27
      28      if is_temp(a1) then
      29          tprev(result) = tprev(a1);
      30      else
      31          tprev(result) = prog_end;
      32      end if;
      33
      34      call emit(q1_asn, t1, a1,  0);
      35
      36      push3(result, t1, op);
      37
      38
      39      end subr gcomp4;
       1 .=member gcomp5
       2      subr gcomp5;
       3
       4$ this routine is called after seeing the right operand of the
       5$ compound operator 'result := a1 op/ [  ]'.  this
       6$ construct seems to imply two iterations:  the first to build the
       7$ tuple, and the second over the tuple applying the operator 'op'.
       8$ since the tuple is never assigned to a program variable, we can
       9$ avoid building it by applying 'op' to successive components of
      10$ the tuple while we execute the iterator.
      11
      12
      13
      14      size op(ps);            $ <*bin> or <*bold> operator
      15      size t1(ps);            $ copy of left operand
      16      size exp(ps);           $ bound variable of 
      17      size temp(ps);          $ temporary in 'temp := t1 op t2;'
      18      size result(ps);        $ temporary for result
      19
      20      size prev(ps);          $ start of loop body
      21      size last(ps);          $ end of loop body
      22
      23
      24      pop4(exp, op, t1, result);
      25
      26      prev = prog_end;        $ save pointer to start of loop body
      27
      28      if is_temp(exp) then    $ move  into loop body
      29          call movblk(tprev(exp), tlast(exp), prev);
      30          prev = tprev(exp);
      31      end if;
      32
      33      push3(t1, exp, op);     $ generate 'temp := t1 op exp;'
      34      if op < user_org then call gbin; else call gubin; end if;
      35      pop1(temp);
      36
      37      call emit(q1_asn, t1, temp, 0);
      38
      39      last = prog_end;        $ install loop body
      40      call gbody(prev, last);   call endlp;
      41
      42      call emit(q1_asn, result, t1, 0);   tlast(result) = prog_end;
      43      push1(result);
      44
      45
      46      end subr gcomp5;
       1 .=member gcomp6
       2      subr gcomp6;
       3
       4$ this routine is called after seeing the right operand of the
       5$ compound operator 'result := a1 op/ a2'.
       6
       7
       8      size op(ps);            $ <*bin> or <*bold> operator
       9      size t1(ps);            $ copy of left operand
      10      size a2(ps);            $ right operand
      11      size t2(ps);            $ bound variable for iteration over a2
      12      size temp(ps);          $ temporary in 'temp := t1 op t2;'
      13      size result(ps);        $ temporary for result
      14
      15      size prev(ps);          $ start of loop body
      16      size last(ps);          $ end of loop body
      17
      18      size gtiter(ps);        $ returns iterator
      19
      20
      21      pop4(a2, op, t1, result);
      22
      23      t2 = gtiter(a2, no);    $ generate iterator over right operand
      24
      25      prev = prog_end;        $ save pointer to start of loop body
      26
      27      push3(t1, t2, op);      $ generate 'temp := t1 op t2;'
      28      if op < user_org then call gbin; else call gubin; end if;
      29      pop1(temp);
      30
      31      call emit(q1_asn, t1, temp, 0);
      32
      33      last = prog_end;        $ install loop body
      34      call gbody(prev, last);   call endlp;
      35
      36      call emit(q1_asn, result, t1, 0);   tlast(result) = prog_end;
      37      push1(result);
      38
      39
      40      end subr gcomp6;
       1 .=member gset1
       2      subr gset1;
       3
       4$ this routine is called when we start processing an iterative
       5$ set former. we allocate two temporaries, one for the result
       6$ and one to count the number of elements. we then initialize
       7$ the counter and push both temporaries onto the stack.
       8
       9
      10      size result(ps),  $ temp for result
      11           counter(ps);  $ counter
      12
      13
      14      result  = gettmp(0);
      15      counter = getvar(0);
      16
      17      tprev(result)  = prog_end;
      18
      19      call emit(q1_asn, counter, sym_zero, 0);
      20
      21      push2(counter, result);
      22
      23
      24      end subr gset1;
       1 .=member gset2
       2      subr gset2;
       3
       4$ this routine is called at the end of a set former of the form
       5
       6$    <<  :  >>
       7
       8$ at this point the top astack entries are  and an auxiliary
       9$ temporary used to count the number of set elements.
      10
      11$ the loop body for the set former will consist of
      12
      13$ 1. code for 
      14$ 2. an instruction to push .
      15$ 3. an instruction to increment the counter.
      16
      17
      18      size exp(ps),   $ expression for set element
      19           result(ps),  $ temp for result
      20           counter(ps);  $ temp for size of set
      21
      22      size prev(ps),  $ pointer to previous instruction
      23           last(ps);  $ pointer to last instruction
      24
      25      size temp(ps);          $ temporary used for counter addition
      26
      27
      28      pop3(exp, result, counter);
      29$
      30$ if  is not a temporary, then generate a new temporary and assign
      31$  to it.  then move the code for  into the loop body.
      32$
      33      if ^ is_temp(exp) then
      34          temp = gettmp(0);   tprev(temp) = prog_end;
      35          call emit(q1_asn, temp, exp, 0);   tlast(temp) = prog_end;
      36          exp = temp;
      37      end if;
      38
      39      call gbody(tprev(exp), tlast(exp));
      40
      41$ emit the push and add instructions then move them into place.
      42
      43      prev = prog_end;
      44
      45      call emit(q1_push, exp, result, 0);
      46
      47      temp = gettmp(0);
      48      tprev(temp) = prog_end;
      49
      50      call emit(q1_add,     temp, counter, sym_one);
      51      call emit(q1_asn,  counter,    temp,       0);
      52
      53      last = prog_end;
      54
      55      call gbody(prev, last);
      56      call endlp;
      57
      58$ emit setformer
      59
      60      call emit(q1_set1,  result,     exp, counter);
      61
      62$ fill in tlast
      63
      64      tlast(result)  = prog_end;
      65
      66      push1(result);
      67
      68
      69      end subr gset2;
       1 .=member gset3
       2      subr gset3;
       3
       4$ this routine processes enumerative setformers. we simply call
       5$ a lower level routine which handles both set and tuple formers.
       6
       7
       8      call settup(q1_set);
       9
      10
      11      end subr gset3;
       1 .=member gset4
       2      subr gset4;
       3
       4$ this routine is called after seeing '<< >>'.
       5
       6      push1(sym_nullset);
       7
       8
       9      end subr gset4;
       1 .=member gtup1
       2      subr gtup1;
       3
       4$ this routine is called at the opening of an iterative tuple
       5$ former. it is equivlent to 'gset1'.
       6
       7      call gset1;
       8
       9
      10      end subr gtup1;
       1 .=member gtup2
       2      subr gtup2;
       3
       4$ this routine is called at the end of an iterative tuple former.
       5$ the code sequence for a tuple former is the same as that for a
       6$ set former except for the opcode of the last instruction. we
       7$ emit a setformer then fix the final opcode.
       8
       9      call gset2;
      10      opcode(prog_end) = q1_tup1;
      11
      12
      13      end subr gtup2;
       1 .=member gtup3
       2      subr gtup3;
       3
       4$ this routine processes enumerative tuple formers. it does this by
       5$ calling a lower level routine.
       6
       7      call settup(q1_tup);
       8
       9
      10      end subr gtup3;
       1 .=member gtup4
       2      subr gtup4;
       3
       4$ this routine is called after seeing '[]'.
       5
       6      push1(sym_nulltup);
       7
       8
       9      end subr gtup4;
       1 .=member settup
       2      subr settup(op);
       3
       4$ this routine processes enumerative set and tuple formers. 'op'
       5$ is either q1_set or q1_tup, indicating the instruction we are
       6$ to emit. before emitting the instruction, we try constant folding.
       7
       8$ the top astack entries are currently:
       9
      10$ 1. a counter 'n'
      11$ 2. n+1 set elements
      12
      13$ we begin by popping 'n' then calling foldst to try to constant
      14$ fold the setformer. if this is successful, we return. otherwise
      15$ we emit a setformer.
      16
      17      size op(ps);  $ q1 opcode
      18
      19      size n(ps),   $ number of elements
      20           success(1),  $ set by foldst
      21           j(ps),       $ loop index
      22           org(ps),  $ origin in astack
      23          temp(ps);  $ temp for result
      24
      25      size args(ps);  $ array of arguments
      26      dims args(nargs_lim);
      27
      28      pop1(n);
      29      n = n + 1;
      30
      31      call foldst(op, n, success);
      32      if (success) return;
      33
      34$ move elements into 'args' then call emitn.
      35
      36      if n >= nargs_lim then
      37          call overfl('settup');
      38
      39      else
      40          temp = gettmp(0);   $ temp for result
      41          args(1) = temp;
      42
      43          org = asp-n;
      44
      45          do j = 1 to n;
      46              args(j+1) = astack(org+j);
      47          end do;
      48
      49          free_stack(n);
      50
      51          call emitn(op, args, n+1);
      52          push1(temp);
      53      end if;
      54
      55
      56      end subr settup;
       1 .=member gname
       2      subr gname;
       3
       4$ this routine is called whever a name appears in an expression.
       5$ we check that we have read access to the name.
       6$ declaration.
       7
       8      size nam(ps);    $ name being processed
       9
      10      nam = astack(asp);
      11      call chkvar(nam);
      12
      13
      14      end subr gname;
       1 .=member gcname
       2      subr gcname;
       3
       4$ this routine is called after seeing a name in a constant
       5$ expression. it is similar to gname.
       6
       7      size nam(ps);
       8
       9      nam = astack(asp);
      10      call chkvar(nam);
      11
      12      if ^ is_const(nam) then
      13          call ermsg(1, nam);
      14          astack(asp) = sym_one;
      15      end if;
      16
      17
      18      end subr gcname;
       1 .=member gint
       2      subr gint;
       3
       4$ this routine is called after seeing an integer denotation. we
       5$ begin by checking whether we have already declared the denotation.
       6$ if so we are done. otherwise we make a val entry for it and reset
       7$ its scope to the current member.
       8
       9      size int(ps),  $ symtab pointer
      10           v(ws),    $ value of integer
      11           fm(ps),  $ form of int
      12           j(ps),  $ loop index
      13           str(sds_sz),   $ name of integer as sds
      14           ch(ps);        $ currnet character of name
      15
      16
      17      int = astack(asp);
      18
      19      is_read(int) = yes;     $ can always read a denotation
      20      if (is_decl(int)) return;
      21
      22$ get name of denotation, then convert value.
      23      str = symsds(int);
      24
      25      v = 0;
      26
      27      do j = 1 to .len. str;
      28          ch = .ch. j, str;
      29          v = 10 * v + digofchar(ch);
      30
      31          if .fb. v > ws-1 then  $ overflow
      32              call ermsg(31, int);
      33              quit;
      34          end if;
      35      end do;
      36
      37      if v <= maxsi then fm = f_sint; else fm = f_int; end if;
      38      form(int) = fm; is_decl(int) = yes; is_repr(int) = yes;
      39      is_store(int) = yes;
      40      countup(valp, val_lim, 'val'); val(valp) = v;
      41      vptr(int) = valp; vlen(int) = 1;
      42
      43
      44      end subr gint;
       1 .=member greal
       2      subr greal;
       3
       4$ this routine is called after seeing an real denotation. we
       5$ begin by checking whether wwe have already declared the denotation.
       6$ if so we are done. otherwise we make a val entry for it and reset
       7$ its scope to the current member.
       8
       9      size r(ps);  $ symtab pointer for denotation
      10
      11      size str(sds_sz),   $ token as sds
      12           len(ps),  $ length of sds
      13           j(ps), $ loop index
      14           v(ws),  $ value of real
      15           expval(ws);  $ exponent value
      16
      17      size char(ps);  $ array of characters
      18      dims char(toklen_lim+3);
      19
      20      r = astack(asp);
      21
      22      is_read(r) = yes;       $ can always read a denotation
      23      if (is_decl(r)) return;
      24
      25$ convert the name of the real to an array of characters, then
      26$ compute its value.
      27
      28      str = symsds(r);
      29      len = .len. str;
      30
      31      if len > toklen_lim then
      32          call ermsg(32, r);
      33          return;
      34      end if;
      35
      36      do j = 1 to len;
      37          char(j) = .ch. j, str;
      38      end do;
      39
      40$ the actual conversion is handled by a series of assembly language
      41$ routines in the little run time library. see the little system
      42$ documentation for details.
      43
      44      call 7nvnum$io(char, len, expval);
      45
      46      if char(len+2) then   $ bad exponent
      47          call ermsg(32, r);
      48          return;
      49      end if;
      50
      51      if char(len+3) > 1 then $ point present, adjust exponent
      52          expval = expval - (char(len+3) - 1);
      53      end if;
      54
      55      call 7ncefr$io(v, char, len, expval);
      56
      57      if ( char(len+2)^= 0 ) call ermsg(86,r);
      58
      59      is_decl(r) = yes;
      60      is_read(r) = yes;
      61      is_repr(r) = yes;
      62      is_store(r) = yes;
      63
      64      form(r) = f_real;
      65
      66      countup(valp, val_lim, 'val');
      67      val(valp) = v;
      68
      69      vptr(r) = valp;
      70      vlen(r) = 1;
      71
      72
      73      end subr greal;
       1 .=member gstr
       2      subr gstr;
       3
       4$ this routine is called after seeing an string denotation. we
       5$ begin by checking whether wwe have already declared the denotation.
       6$ if so we are done. otherwise we make a val entry for it and reset
       7$ its scope to the current member.
       8
       9      size string(ps),  $ symtab pointer
      10           str(sds_sz),  $ string in sds form
      11           words(ps),  $ number of words in value
      12           j(ps);    $ loop index
      13
      14      string = astack(asp);
      15
      16      is_read(string) = yes;  $ can always read a denotation
      17      if (is_decl(string)) return;
      18
      19$ string values are represented in the same format as 'names' entries.
      20$ however we cannot simply copy the names entry for the string,
      21$ but must strip off the enclosing quotes.
      22
      23      str = symsds(string);   $ get original string
      24      str = .s. 2, .len. str-2, str;   $ strip quotes
      25
      26      words = sorg str/ws;   $ number of words in value
      27
      28      vptr(string) = valp+1;
      29      vlen(string) = words;
      30
      31      do j = 0 to words-1;
      32          countup(valp, val_lim, 'val');
      33          val(valp) = .f. 1+j*ws, ws, str;
      34      end do;
      35
      36      is_decl(string)  = yes;
      37      is_read(string)  = yes;
      38      is_repr(string)  = yes;
      39      is_store(string) = yes;
      40
      41      form(string)  = f_string;
      42
      43
      44      end subr gstr;
       1 .=member giter1
       2      subr giter1;
       3
       4$ this routine is called at the start of each iterator. we begin
       5$ by building a new cstack entry and obtaining labels for the
       6$ doing, step, and term blocks. after this we build a skeleton
       7$ for the iterator as if there were empty clauses for init, doing, etc.
       8$ when we encounter the actual clauses suppied by the user, we
       9$ will simply insert them in the proper place.
      10
      11
      12
      13$ begin by making a cstack entry.
      14      countup(csp, cstack_lim, 'cstack');
      15      cstack(csp) = 0;
      16      cs_type(csp) = cs_iter;
      17
      18$ get labels for the doing, step and term blocks.
      19      cs_ldoing(csp) = getlab(0);
      20      cs_lstep(csp)  = getlab(0);
      21      cs_lterm(csp)  = getlab(0);
      22      cs_lquit(csp)  = getlab(0);
      23
      24$ create null init block
      25      call emit(q1_noop, 0, 0, 0);
      26      cs_init(csp) = prog_end;
      27
      28$ create doing block and define doing label
      29      call deflab(cs_ldoing(csp));
      30      cs_doing(csp) = prog_end;
      31
      32$ create while block
      33      call emit(q1_noop, 0, 0, 0);
      34      cs_while(csp) = prog_end;
      35
      36$ create where block
      37      call emit(q1_noop, 0, 0, 0);
      38      cs_where(csp) = prog_end;
      39
      40$ emit null body
      41      call emit(q1_noop, 0, 0, 0);
      42      cs_body(csp) = prog_end;
      43
      44$ emit step block and define step label
      45      call deflab(cs_lstep(csp));
      46      cs_step(csp) = prog_end;
      47$
      48$ create until block
      49$
      50      $ the until block will contain a series of statements of the
      51      $ form:
      52      $     if  then go to term; end;
      53      call emit(q1_noop, 0, 0, 0);
      54      cs_until(csp) = prog_end;
      55
      56$ emit 'go to doing block' followed by term label
      57      call emit(q1_goto, cs_ldoing(csp), 0, 0);
      58
      59      call deflab(cs_lterm(csp));
      60      cs_term(csp) = prog_end;
      61
      62$
      63$ define label for quit statements
      64$
      65      $ note that this label does not define another block.
      66      call deflab(cs_lquit(csp));
      67
      68      if trs_flag then   $ dump cstack
      69          put, skip, 'exiting gloop at stmt ': stmt_count, i, skip;
      70          call csdump;
      71      end if;
      72
      73
      74      end subr giter1;
       1 .=member giter2
       2      subr giter2;
       3
       4$ this routine is called just before seeing a  , i.e.
       5$ a sequence ', '. the code for each  must
       6$ be placed inside the body of the surrounding iterator.
       7$ in order to do this, we must save a code pointer to the
       8$ start of the .
       9
      10      push1(prog_end);
      11
      12
      13      end subr giter2;
       1 .=member giter3
       2      subr giter3;
       3
       4$ this routine is called after seeing a , i.e. an
       5$ inner loop in a compound iterator. we move the code for the
       6$ iterator into the body of the outer iterator and reset
       7$ the type of its cstack entry.
       8
       9      size prev(ps),  $ previous instruction
      10           last(ps);  $ last instruction
      11
      12      pop1(prev);
      13      last = prog_end;
      14
      15$ move iterator
      16      call movblk(prev, last, cs_body(csp-1));
      17      cs_body(csp-1) = last;
      18
      19
      20      cs_type(csp) = cs_citer;  $ reset type
      21
      22
      23      end subr giter3;
       1 .=member ginit1
       2      subr ginit1;
       3
       4$ this routine is called at the start of an init block.
       5$ we save a pointer to the start of the block on astack.
       6
       7      push1(prog_end);
       8
       9
      10      end subr ginit1;
       1 .=member ginit2
       2      subr ginit2;
       3
       4$ this routine is called after seeing an init block.
       5$ we simply move the block into place.
       6
       7      size prev(ps),   $ start of block
       8           last(ps);   $ end of block
       9
      10      pop1(prev);
      11      last = prog_end;
      12
      13      if (prev = last) return;    $ null block
      14
      15      call movblk(prev, last, cs_init(csp));
      16      cs_init(csp) = last;
      17
      18
      19      end subr ginit2;
       1 .=member ginit3
       2      subr ginit3(exp);
       3
       4$ this routine moves the code for an expression into the init block of
       5$ the current loop.
       6
       7      size exp(ps);   $ temporary yielded by expression
       8
       9      size prev(ps),  $ its tprev
      10           last(ps),  $ its tlast
      11           p(ps);     $ pointer to init block
      12
      13      if (^ is_temp(exp)) return;  $ not expression
      14
      15      prev = tprev(exp);
      16      last = tlast(exp);
      17      p    = cs_init(csp);
      18
      19      call movblk(prev, last, p);
      20
      21      cs_init(csp) = last;   $ reset end of ini block
      22
      23
      24      end subr ginit3;
       1 .=member gdng1
       2      subr gdng1;
       3
       4$ this routine is called at the start of a doing block. it is similar
       5$ to ginit1
       6
       7      push1(prog_end);
       8
       9
      10      end subr gdng1;
       1 .=member gdng2
       2      subr gdng2;
       3
       4$ this routine is called after seeing a doing block. it is similar to
       5$ ginit2.
       6
       7      size prev(ps),  $ pointer to start of block
       8           last(ps);
       9
      10      pop1(prev);
      11      last = prog_end;
      12
      13      if (prev = last) return;    $ null block
      14
      15      call movblk(prev, last, cs_doing(csp));
      16      cs_doing(csp) = last;
      17
      18
      19      end subr gdng2;
       1 .=member gwhile
       2      subr gwhile;
       3
       4$ this routine is called after seeing 'while exp'.
       5$ we move the expresion into place and insert a test.
       6
smfe  12      size exp(ps);           $ symtab pointer for expression
smfe  13      size prev(ps);          $ pointer to start of block
smfe  14      size last(ps);          $ pointer to end of block
smfe  15      size true1(ps);         $ true label for boolean expression
smfe  16      size false1(ps);        $ false label for boolean expression
smfe  17      size lab(ps);           $ step label
       9
smfe  18
      10      pop1(exp);
      11
smfe  19      prev = prog_end;
smfe  20      lab  = cs_lterm(csp);
smfe  21
smfe  22      until 1;
smfe  23          until 2;
smfe  24              if (is_temp(exp) = no) quit until 2;
smfe  25
smfe  26              call movblk(tprev(exp), tlast(exp), prev);
smfe  27              prev = tprev(exp);
smfe  28
smfe  29              if (bsp = 0)             quit until 2;
smfe  30              if (exp ^= bs_temp(bsp)) quit until 2;
smfe  31
smfe  32              true1 = bs_true(bsp); false1 = bs_false(bsp);
smfe  33              call gbool(q1_ifnot, exp, yes, true1, false1, lab);
smfe  34              bsp = bsp - 1;
smfe  35
smfe  36              quit until 1;
smfe  37
smfe  38          end until 2;
smfe  39
smfe  40          call emit(q1_ifnot, exp, lab, 0);
smfe  41
smfe  42      end until 1;
smfe  43
smfe  44      last = prog_end; call movblk(prev, last, cs_while(csp));
smfe  45      cs_while(csp) = last;
      21
      22
      23      end subr gwhile;
       1 .=member gwhere
       2      subr gwhere;
       3
       4$ this routine is called after seeing 'where exp'.
       5$ it is similar to gwhile.
       6
smfe  46      size exp(ps);           $ symtab pointer for expression
smfe  47      size prev(ps);          $ pointer to start of block
smfe  48      size last(ps);          $ pointer to end of block
smfe  49      size true1(ps);         $ true label for boolean expression
smfe  50      size false1(ps);        $ false label for boolean expression
smfe  51      size lab(ps);           $ step label
       9
smfe  52
      10      pop1(exp);
      11
smfe  53      prev = prog_end;
smfe  54      lab  = cs_lstep(csp);
smfe  55
smfe  56      until 1;
smfe  57          until 2;
smfe  58              if (is_temp(exp) = no) quit until 2;
smfe  59
smfe  60              call movblk(tprev(exp), tlast(exp), prev);
smfe  61              prev = tprev(exp);
smfe  62
smfe  63              if (bsp = 0)             quit until 2;
smfe  64              if (exp ^= bs_temp(bsp)) quit until 2;
smfe  65
smfe  66              true1 = bs_true(bsp); false1 = bs_false(bsp);
smfe  67              call gbool(q1_ifnot, exp, yes, true1, false1, lab);
smfe  68              bsp = bsp - 1;
smfe  69
smfe  70              quit until 1;
smfe  71
smfe  72          end until 2;
smfe  73
smfe  74          call emit(q1_ifnot, exp, lab, 0);
smfe  75
smfe  76      end until 1;
smfe  77
smfe  78      last = prog_end; call movblk(prev, last, cs_where(csp));
smfe  79      cs_where(csp) = last;
      21
      22
      23      end subr gwhere;
       1 .=member gbody
       2      subr gbody(prev, last);
       3
       4$ this routine inserts a block of code into the loop body.
       5$ we simply move the block to the end of the body clause.
       6
       7      size prev(ps),  $ pointer to start of block to be moved
       8           last(ps);    $ pointer to end of block
       9
      10      size p(ps);  $ pointer to end of body
      11
      12
      13      p = cs_body(csp);
      14
      15      call movblk(prev, last, p);
      16      cs_body(csp) = last;
      17
      18
      19      end subr gbody;
       1 .=member gstep1
       2      subr gstep1;
       3
       4$ this routine is called at the start of a step block. it is similar
       5$ to ginit1
       6
       7
       8      push1(prog_end);
       9
      10
      11      end subr gstep1;
       1 .=member gstep2
       2      subr gstep2;
       3
       4$ this routine is called after seeing a step block. it is similar to
       5$ ginit2.
       6
       7
       8      size prev(ps),  $ pointer to start of block
       9           last(ps);  $ pointer to end of block
      10
      11
      12      pop1(prev);
      13      last = prog_end;
      14
      15      if (prev = last) return;    $ null block
      16
      17      call movblk(prev, last, cs_step(csp));
      18      cs_step(csp) = last;
      19
      20
      21      end subr gstep2;
       1 .=member guntil
       2      subr guntil;
       3
       4$ this routine is called after seeing 'until exp'.
       5$ it is similar to gwhile.
       6
smfe  80      size exp(ps);           $ symtab pointer for expression
smfe  81      size prev(ps);          $ pointer to start of block
smfe  82      size last(ps);          $ pointer to end of block
smfe  83      size true1(ps);         $ true label for boolean expression
smfe  84      size false1(ps);        $ false label for boolean expression
smfe  85      size lab(ps);           $ step label
      10
      11
      12      pop1(exp);
      13
smfe  86      prev = prog_end;
smfe  87      lab  = cs_lterm(csp);
smfe  88
smfe  89      until 1;
smfe  90          until 2;
smfe  91              if (is_temp(exp) = no) quit until 2;
smfe  92
smfe  93              call movblk(tprev(exp), tlast(exp), prev);
smfe  94              prev = tprev(exp);
smfe  95
smfe  96              if (bsp = 0)             quit until 2;
smfe  97              if (exp ^= bs_temp(bsp)) quit until 2;
smfe  98
smfe  99              true1 = bs_true(bsp); false1 = bs_false(bsp);
smfe 100              call gbool(q1_if, exp, yes, true1, false1, lab);
smfe 101              bsp = bsp - 1;
smfe 102
smfe 103              quit until 1;
smfe 104
smfe 105          end until 2;
smfe 106
smfe 107          call emit(q1_if, exp, lab, 0);
smfe 108
smfe 109      end until 1;
smfe 110
smfe 111      last = prog_end; call movblk(prev, last, cs_until(csp));
smfe 112      cs_until(csp) = last;
      23
      24
      25      end subr guntil;
       1 .=member gterm1
       2      subr gterm1;
       3
       4$ this routine is called at the start of a term block. it is similar
       5$ to ginit1
       6
       7
       8      push1(prog_end);
       9
      10
      11      end subr gterm1;
       1 .=member gterm2
       2      subr gterm2;
       3
       4$ this routine is called after seeing a term block. it is similar to
       5$ ginit2.
       6
       7
       8      size prev(ps),  $ pointer to start of block
       9           last(ps);  $ pointer to end of block
      10
      11
      12      pop1(prev);
      13      last = prog_end;
      14
      15      if (prev = last) return;    $ null block
      16
      17      call movblk(prev, last, cs_term(csp));
      18      cs_term(csp) = last;
      19
      20
      21      end subr gterm2;
       1 .=member endlp
       2      subr endlp;
       3
       4$ this routine pops the cstack entries for a compound iterator.
       5
       6
       7      while cs_type(csp) = cs_citer;  $ pop the inner loops
       8          csp = csp-1;
       9      end while;
      10
      11      csp = csp - 1;  $ pop the outer loop
      12
      13
      14      end subr endlp;
       1 .=member garith
       2      subr garith;
       3
       4$ this routine processes arithmetic iterators.  the iterator
smfb 440$ 'i in [ e1, e2 .. e3 ]' is treated as:
       6$
smfb 441$    init   i  := t1 := e1;
smfb 442$           t2 := e2-t1;
       9$           t3 := e3;
      10$
smfb 443$    while  t1 <= t3
      12$
smfb 444$    step   temp := t1 + t2;
smfb 445$           i := t1 := temp;
      15$
      16$    term   i := om;
      17$
      18$ note that 'i' is a variable, not a general left hand side.
      19$
      20$ if the user has seleted the 'diter' control card option, we suppress
      21$ the internal variables.
      22
      23
      24      size i(ps);             $ bound variable
      25      size e1(ps);            $ initial value
      26      size e2(ps);            $ second value
      27      size e3(ps);            $ final value
      28
smfb 446      size t1(ps);            $ shadow variable for 'i'
smfb 447      size t2(ps);            $ temporary for increment
      31      size t3(ps);            $ shadow variable for e3
      32      size t4(ps);            $ temporaries used in while test
      33      size t5(ps);
      34      size t6(ps);
      35      size temp(ps);          $ temporary used in step
      36
      37      size op(ps);            $ comparison operator
      38      size v(ps);             $ value of increment
      39
      40      size prev(ps);          $ pointer to start of code block
      41      size last(ps);          $ pointer to end of code block
      42
      43      size fndinc(ps);        $ function to find increment
      44
      45
      46      pop4(e3, e2, e1, i);
      47
      48      if bvar_flag then  $ save bound variable
      49          if is_temp(i) then
      50              cs_bvar(csp) = copy(i);
      51          else
      52              cs_bvar(csp) = i;
      53          end if;
      54      end if;
smfb 448$
smfb 449$ emit init block
smfb 450$
smfb 451$  - emit the code for 'i := t1 := e1;'.
smfb 452$
smfb 453      if diter_flag & (form(i) = f_int ! form(i) = f_gen) then
smfb 454          t1 = i;
smfb 455      else
smfb 456          t1 = getvar(0);   is_back(t1) = yes;
smfb 457          if is_fint(form(i)) then
smfb 458              form(t1) = form(i); is_repr(t1) = yes;
smfb 459          end if;
smfb 460      end if;
smfb 461
smfb 462      call ginit3(e1);  $ move e1 into the init block
smfb 463
smfb 464      prev = prog_end;
smfb 465      call emit(q1_asn, t1, e1, 0);  $ emit initialisation
smfb 466      if (i ^= t1) call emit(q1_asn, i, t1, 0);
smfb 467      last = prog_end;
smfb 468      call movblk(prev, last, cs_init(csp)); cs_init(csp) = last;
smfb 469$
smfb 470$  - emit 't2 = e2 - e1'.  note that we use t1 instead of e1 in the
smfb 471$    code emitted.
smfb 472$
smfb 473      $ note that e2 may not be present in the user's program.
smfb 474      if (e2 ^= 0) call ginit3(e2);  $ move e2 into the init block
smfb 475
smfb 476      $ note that fndinc might generate code;  also note that fndinc
smfb 477      $ might delete the code for e2.  for this reason we emit a no-op
smfb 478      $ here to make sure that the code fragment for e2 is neither at
smfb 479      $ the end of the program nor at the end of the init block.
smfb 480      prev = prog_end; call emit(q1_noop, 0, 0, 0); last = prog_end;
smfb 481      call movblk(prev, last, cs_init(csp)); cs_init(csp) = last;
smfb 482
smfb 483      prev = prog_end;
smfb 484
smfb 485      t2 = fndinc(t1, e1, e2);  $ find the increment
smfb 486
smfb 487      if t2 = sym_zero then
smfb 488          call emit(q1_goto, cs_lterm(csp), 0, 0);
smfb 489      elseif ^ is_const(t2) then
smfb 490          push3(t2, sym_zero, sym_eq); call gbin; pop1(temp);
smfb 491          call emit(q1_if, temp, cs_lterm(csp), 0);
smfb 492      end if;
smfb 493
smfb 494      if prev ^= prog_end then
smfb 495          last = prog_end;
smfb 496          call movblk(prev, last, cs_init(csp)); cs_init(csp) = last;
smfb 497      end if;
smfb 498$
smfb 499$  - emit the code for 't3 := e3;'.
smfb 500$
smfb 501      if is_const(e3) then
smfb 502          if ( ^ is_fint(ft_deref(form(e3)))) call ermsg(17, e3);
smfb 503          t3 = e3;
smfb 504      else
smfb 505          t3 = getvar(0); is_back(t3) = yes;
smfb 506          if is_fint(form(e3)) then
smfb 507              form(t3) = form(e3); is_repr(t3) = yes;
smfb 508          end if;
smfb 509
smfb 510          call ginit3(e3);  $ move e3 into the init block
smfb 511          prev = prog_end;
smfb 512          call emit(q1_asn, t3, e3, 0); last = prog_end;
smfb 513          call movblk(prev, last, cs_init(csp)); cs_init(csp) = last;
smfb 514      end if;
     106
     107$ emit the 'while' test. there are several possibilities:
     108
     109$ 1. no upper bound is given(e3 = 0). dont emit any test.
     110
     111$ 2. the increment, namely t1, is constant. if t1 is positive, we
     112$    emit 'while i <= t3'; otherwise we emit 'while i >= t3'.
     113
     114$ 3. the increment is a variable. we emit 'while if t1 >= 0 then
     115$    i <= t3 else i >= t3'.
     116
     117      if e3 = 0 then
     118          push1(sym_one)
     119
smfb 515      elseif is_const(t2) then  $ constant increment
     121
smfb 516          v = symval(t2); $ look at sign of increment
smfb 517          if v > 0 then op = sym_le; else op = sym_ge; end if;
smfb 518          push3(t1, t3, op); call gbin;  $ emit comparison
     132
     133      else
     134          $ (
smfb 519          $   t4 := (t2 >=  0);
smfb 520          $   t5 := (t1 <= t3);
smfb 521          $   t6 := (t1 >= t3);
     138          $   if t4 then t5 else t6
     139          $ )
smfb 522          t4 = gettmp(0); call emit(q1_pos, t4, t2, sym_zero);
smfb 523          t5 = gettmp(0); call emit(q1_ge,  t5, t3, t1);
smfb 524          t6 = gettmp(0); call emit(q1_ge,  t6, t1, t3);
     143          call gcond(t4, t5, t6);
     144      end if;
     145
     146      call gwhile;
     147$
     148$ emit step block
     149$
     150      prev = prog_end;
     151
smfb 525      push3(t1, t2, sym_plus); call gbin; pop1(temp);
     153
smfb 526      call emit(q1_asn, t1, temp, 0);
smfb 527      if (i ^= t1) call emit(q1_asn, i, t1, 0);
     156
     157      last = prog_end;
     158      call movblk(prev, last, cs_step(csp));
     159      cs_step(csp) = last;
     160$
     161$ emit term block
     162$
     163      prev = prog_end;
     164      call emit(q1_asn, i, sym_om, 0);
     165      last = prog_end;
     166      call movblk(prev, last, cs_term(csp));
     167      cs_term(csp) = last;
     168
     169
     170      end subr garith;
       1 .=member fndinc
       2      fnct fndinc(var, e1, e2);
       3
       4$ this routine finds the increment in an iterator (! i := e1, e2, ...)
       5$ there are two possibilities:
       6
       7$ 1. e1 and e2 differ by a constant. this will occur in cases such
       8$    as (! i := ? s, ? s-1 ... 1). in this case we can return the
       9$    constant -1.
      10
      11$ 2. otherwise we must emit code to calculate the increment at
      12$    run time.
      13
      14$ note that in case(2), e1 will be used twice: once to initialize
      15$ 'i' and once to calculate the increment. this violates a basic
      16$ assumption of the compiler, namely that each temporary is only
      17$ used once.
      18
      19$ in order to avoid this problem we emit an assignment
      20$ 'internal variable := e1' before calling fndinc. if
      21$ it proves necessary to emit a code to find the increment
      22$ we will use this variable rather than e1.
      23
      24$ the reason we pass both 'var' and 'e1' as arguments to
      25$ fndinc is that it is necessary to walk the code fragment
      26$ of e1 and compare it with the code fragment of e2.
      27
      28$ we begin by looking for three special cases:
      29
      30$ (1)   i := e1 ....
      31
      32$ (2)   i := e1, e1+n, ....
      33
      34$ (3)   i := e1, e1-n, ...
      35
      36$ where n is an integer constant. case (1) is identified by e2 = 0.
      37
      38$ note that findinc returns either a constant or an internal
      39$ variable, never a temporary.
      40
      41      size var(ps),   $ internal variable := e1
      42           e1(ps),    $ initial value
      43           e2(ps);  $ second value
smfb 528      size v1(ws), v2(ws);    $ values of integer constants
smfb 529      size v(ws);             $ value of integer constant
      44
      45      size fndinc(ps);  $ temp or constant returned
      46
smfb 530      size i1(ps);            $ instruction for e1
smfb 531      size op1(ps);           $ operator of e1
smfb 532      size a2(ps), a3(ps);    $ operands of e1
smfb 533      size i2(ps);            $ instruction for e2
smfb 534      size op2(ps);           $ operator of e2
smfb 535      size b2(ps), b3(ps);    $ operands of e2
      52
      53      size t(ps);  $ result of subtraction
      54
      55      size eqexp(1);   $ compares two expressions for equality
      56      size getint(ps);        $ returns symtab pointer for integer const
      57
      58      if e2 = 0 then  $ increment is 1.
      59          fndinc = sym_one;
      60          return;
      61
      62      elseif is_temp(e2) then  $ might be e1+ or e1-.
smfb 536
smfb 537          i2 = tlast(e2); op2 = opcode(i2);
smfb 538          b2 = arg2(i2); b3 = arg3(i2);
smfb 539
smfb 540          if (op2 = q1_add ! op2 = q1_sub) & is_const(b3) then
smfb 541              if ( ^ is_fint(ft_deref(form(b3)))) call ermsg(17, b3);
smfb 542
smfb 543              if eqexp(e1, b2) then
smfb 544                  call killex(e2);
smfb 545                  if op2 = q1_add then
smfb 546                      fndinc = b3;
smfb 547                  else
smfb 548                      v = symval(b3); fndinc = getint(-v);
smfb 549                  end if;
smfb 550                  return;
smfb 551              end if;
smfb 552
smfb 553              if is_temp(e1) then
smfb 554
smfb 555                  i1 = tlast(e1); op1 = opcode(i1);
smfb 556                  a2 = arg2(i1); a3 = arg3(i1);
smfb 557
smfb 558                  if (op1 = q1_add ! op1 = q1_sub) &
smfb 559                          is_const(a3) & eqexp(a2, b2) then
smfb 560                      if ^ is_fint(ft_deref(form(a3))) then
smfb 561                          call ermsg(17, a3);
smfb 562                      end if;
smfb 563                      call killex(e2);
smfb 564                      v1 = symval(a3); v2 = symval(b3);
smfb 565                      if op1 = op2 then v = v1-v2; else v = v1+v2; end;
smfb 566
smfb 567                      if op1 = q1_add then
smfb 568                          fndinc = getint(-v);
smfb 569                      else
smfb 570                          fndinc = getint(v);
smfb 571                      end if;
smfb 572                      return;
smfb 573                  end if;
smfb 574              end if;
smfb 575          end if;
smfb 576
smfb 577      elseif is_const(e1) & is_const(e2) then
smfb 578          if ( ^ is_fint(ft_deref(form(e1)))) call ermsg(17, e1);
smfb 579          if ( ^ is_fint(ft_deref(form(e2)))) call ermsg(17, e2);
smfb 580          v1 = symval(e1); v2 = symval(e2); fndinc = getint(v2-v1);
smfb 581          return;
      82      end if;
      83
      84$ otherwise call gbin to emit 'e2-e1'. gbin will return a constant
      85$ or a temporary. in the latter case we assign it to an internal
      86$ variable.
      87
      88      push3(e2, var, sym_minus);   call gbin;   pop1(t);
      89
      90      if is_temp(t) then
      91          fndinc = getvar(0);   is_back(fndinc) = yes;
      92          call emit(q1_asn, fndinc, t, 0);
      93      else
      94          fndinc = t;
      95      end if;
      96
      97
      98      end fnct fndinc;
       1 .=member gnonam
       2      subr gnonam;
       3
       4$ this routine is called at the start of an iterator such as
       5$ '1 ... n'. we supply a temporary for the bound variable.
       6
       7$ note that we must clear the temporaries 'is_temp' bit so that
       8$ it looks like a variable when we make assignments to it.
       9
      10      size t(ps);   $ temp used as bound variable
      11
      12      t = getvar(0);
      13      is_back(t) = yes;
      14
      15      push1(t);
      16
      17      return;
      18
      19      end subr gnonam;
       1 .=member gnolow
       2      subr gnolow;
       3
       4$ this routine supplies the default lower bound for an arithmetic
       5$ iterator.
       6
       7      push1(sym_one);
       8      call gnostp;
       9
      10      return;
      11
      12      end subr gnolow;
       1 .=member gnostp
       2      subr gnostp;
       3
       4$ this routine is called when the second expression in an arithmetic
       5$ iterator is missing. we push a zero onto the stack.
       6
       7      push1(0);
       8      return;
       9
      10      end subr gnostp;
       1 .=member gseti
       2      subr gseti;
       3
       4$ this routine processes set iterators.  the iterator 'x in s' is
       5$ treated as:
       6$
       7$    init    t1 := s;
       8$            inext(t2, t3, t1);
       9$
      10$    doing   next(t2, t3, t1);
      11$            if t3 = om then go to term; end;
      12$            x := t2;
      13$
      14$        
      15$
      16$    term:   t1 := om;
      17$            x  := om;
      18$
      19$ as with arithmetic iterators, the code is simplified if the user
      20$ has selected the 'diter' control card option.
      21
      22
      23      size s(ps);             $ set being iterated over
      24      size x(ps);             $ element of s
      25      size x_term(ps);        $ copy of code fragment for x
      26
      27      size t1(ps);            $ shadow variable for s
      28      size t2(ps);            $ shadow variable for x
      29      size t3(ps);            $ extra temporary needed by 'next'
      30      size t4(ps);            $ temporary for omega test
      31
      32      size prev(ps);          $ pointer to start of code block
      33      size last(ps);          $ pointer to end of code block
      34
      35
      36      pop2(s, x);
      37
      38      if bvar_flag then       $ save bound variable
      39          if is_temp(x) then
      40              cs_bvar(csp) = copy(x);
      41          else
      42              cs_bvar(csp) = x;
      43          end if;
      44      end if;
      45
      46      $ if x is a temporary, it must be of the form [x1, ..., xn].
      47      $ to be able to assign omega to the xi, we need a copy of the
      48      $ code fragment for x.  get it before the call to gasn in the
      49      $ doing block destroys it.
      50      if is_temp(x) then x_term = copy(x); else x_term = x; end if;
      51
      52      if diter_flag & ^ is_temp(s) then  $ use 's' directly
      53          t1 = s;
      54      else
      55          t1 = getvar(0);   is_back(t1) = yes;
      56      end if;
      57
      58      if diter_flag
      59          & ^ is_temp(x)
      60          & (form(x) = ft_elmt(form(s)) ! form(x) = f_gen) then
      61
      62          t2 = x;
      63      else
      64          t2 = getvar(0);   is_back(t2) = yes;
      65      end if;
      66
      67      t3 = getvar(0);   is_back(t3) = yes;
      68
      69      $ if s is an expression, we must move the code for it into
      70      $ the init block.
      71      call ginit3(s);
      72$
      73$ emit init block
      74$
      75      prev = prog_end;
      76
      77      if (t1 ^= s) call emit(q1_asn, t1, s, 0);
      78      call emit(q1_inext, t2, t3, t1);
      79
      80      last = prog_end;
      81      call movblk(prev, last, cs_init(csp));
      82      cs_init(csp) = last;
      83$
      84$ emit doing block
      85$
      86      prev = prog_end;
      87
      88      call emit(q1_next, t2, t3, t1);
      89
      90      $ emit test for omega
      91      push3(t3, sym_om, sym_eq);   call gbin;
      92      pop1(t4);   call emit(q1_if, t4, cs_lterm(csp), 0);
      93
      94      if (t2 ^= x) call gasn(x, t2, no);
      95
      96      $ move doing block into place
      97      last = prog_end;
      98      call movblk(prev, last, cs_doing(csp));
      99      cs_doing(csp) = last;
     100$
     101$ emit term block
     102$
     103      prev = prog_end;
     104
     105      if (t1 ^= s) call emit(q1_asn, t1, sym_om, 0);
     106      if (t2 ^= x_term) call gasn(x_term, sym_om, yes);
     107
     108      last = prog_end;
     109      call movblk(prev, last, cs_term(csp));
     110      cs_term(csp) = last;
     111
     112
     113      end subr gseti;
       1 .=member gdomi1
       2      subr gdomi1;
       3
       4$ this routine generates the iterator 'y := f(x1 ... xn)'
       5
       6      call gdomi(no);
       7      return;
       8
       9      end subr gdomi1;
       1 .=member gdomi2
       2      subr gdomi2;
       3
       4$ this routine generates the iterator 'y := f<>'
       5
       6      call gdomi(yes);
       7      return;
       8
       9      end subr gdomi2;
       1 .=member gdomi
       2      subr gdomi(c);
       3
       4$ this is the main routine for processing domain iterators.
       5$
       6$ the parameter 'c' indicates whether we process 'y = f(x0, ..., xn)'
       7$ or 'y = f<>'.
       8$
       9$ we treat (forall y = f(x)) as a short form for:
      10$
      11$    init     t1 = f;
      12$             inextd(t3, t2, t1);
      13$
      14$    doing    nextd(t3, t2, t1);
      15$             if t2 = om then go to term; end;
      16$             t4 := t1(t3);
      17$             y  := t4;
      18$
      19$ if we generate code for 'y = f(x)', we have to assign
      20$
      21$             x  := t3;
      22$
      23$ otherwise we generate
      24$
      25$             [x1, ..., xn] = t3;
      26$
      27$        
      28$
      29$    term:    t1 := om;
      30$             x  := om;
      31$             y  := om;
      32
      33
      34      size c(1);              $ flags iterator 'y = f<>'
      35
      36      size n(ps);             $ number of domain indices minus one
      37      size f(ps);             $ the map we iterate over
      38      size y(ps);             $ map range
      39      size y_term(ps);        $ copy of code fragment for y
      40      size x(ps);             $ map domain
      41      size x_term(ps);        $ copy of code fragment for x
      42      size t1(ps);            $ shadow variable for 'f'
      43      size t2(ps);            $ iterator-format pointer
      44      size t3(ps);            $ domain element of 'f'
      45      size t4(ps);            $ range element of 'f'
      46      size prev(ps);          $ pointer to start of init/doing block
      47      size last(ps);          $ pointer to end of init/doing block
      48
      49
      50      pop1(n);
      51
      52      f = astack(asp-n-1);
      53      y = astack(asp-n-2);
      54
      55      $ if y is a temporary, it must be of the form [y1, ..., yn].
      56      $ to be able to assign omega to the yi, we need a copy of the
      57      $ code fragment for y.  get it before the call to gasn in the
      58      $ doing block destroys it.
      59      if is_temp(y) then y_term = copy(y); else y_term = y; end if;
      60
      61      $ if 'f' is an expression, we must move the code for it into
      62      $ the init block.
      63      if (is_temp(f)) call ginit3(f);
      64
      65      $ get a shadow variable for 'f' if necessary.
      66      if diter_flag & ^ is_temp(f) then
      67          t1 = f;
      68      else
      69          t1 = getvar(0);   is_back(t1) = yes;
      70      end if;
      71
      72      t2 = getvar(0);   is_back(t2) = yes;
      73      t3 = getvar(0);   is_back(t3) = yes;
      74$
      75$ emit init block
      76$
      77      prev = prog_end;
      78
      79      if (t1 ^= f) call emit(q1_asn, t1, f, 0);
      80      call emit(q1_inextd, t3, t2, t1);
      81
      82      last = prog_end;
      83      call movblk(prev, last, cs_init(csp));
      84      cs_init(csp) = last;
      85$
      86$ emit doing block
      87$
      88      prev = prog_end;
      89
      90      call emit(q1_nextd,  t3, t2, t1);
      91
      92      $ emit test for omega
      93      push3(t2, sym_om, sym_eq);   call gbin;
      94      pop1(t4);   call emit(q1_if, t4, cs_lterm(csp), 0);
      95
      96      $ emit range retrieval
      97      push3(t1, t3, 0);
      98      if c then call gofa; else call gof; end if;
      99      pop1(t4);   call gasn(y, t4, no);
     100
     101      $ emit domain retrievals and assignments
     102      if n > 0 then
     103          push1(n);   call gtup3;
     104      end if;
     105
     106      pop1(x);
     107
     108      $ if x is a temporary, it must be of the form [x1, ..., xn].
     109      $ to be able to assign omega to the xi, we need a copy of the
     110      $ code fragment for x.  get it before the following call to
     111      $ gasn destroys it.
     112      if is_temp(x) then x_term = copy(x); else x_term = x; end if;
     113
     114      call gasn(x, t3, no);
     115
     116      $ move doing block into place
     117      last = prog_end;
     118      call movblk(prev, last, cs_doing(csp));
     119      cs_doing(csp) = last;
     120$
     121$ emit term block
     122$
     123      prev = prog_end;
     124
     125      if(t1 ^= f) call emit(q1_asn, t1, sym_om, 0);
     126
     127      call gasn(x_term, sym_om, yes);
     128      call gasn(y_term, sym_om, yes);
     129
     130      last = prog_end;
     131      call movblk(prev, last, cs_term(csp));
     132      cs_term(csp) = last;
     133
     134      free_stack(2);          $ 'f' and 'y'
     135
     136
     137      end subr gdomi;
       1 .=member gbvar1
       2      subr gbvar1;
       3
       4$ this routine is called before the iterator in << x in s st c(x) >>.
       5$ we set bvar_flag to indicate that it is necessary to save the
       6$ bound variable 'x'.
       7
       8      push1(bvar_flag);  $ save old value
       9
      10      bvar_flag = yes;
      11
      12
      13      end subr gbvar1;
       1 .=member gbvar2
       2      subr gbvar2;
       3
       4$ this routine is called after seeing the iterator in
       5$ << x in s st c(x) >>.  we check that the iterator had a bound
       6$variable, and then push it onto the stack.
       7
       8      size bvar(ps);  $ bound variable
       9
      10      bvar = cs_bvar(csp);
      11
      12      if bvar = 0 then
      13          call ermsg(33, 0);
      14          bvar = sym_one;
      15      end if;
      16
      17      pop1(bvar_flag);
      18      push1(bvar);
      19
      20
      21      end subr gbvar2;
       1 .=member gtiter
       2      fnct gtiter(s, citer);
       3
       4$ this routine opens an iterator '(! t _ s)' and returns a pointer
       5$ to 't'.
       6
       7$ 'citer' flags a 
       8
       9$ we begin by allocating 't', then setting its is_temp flag to 0.
      10$ this is necessary so that assignments to t will be done as simple
      11$ assignments.
      12
      13      size s(ps),   $ set we are iterating over
      14           citer(1);  $ flags  in grammar
      15
      16      size gtiter(ps);        $ bound variable returrned
      17
      18      gtiter = getvar(0);
      19
      20$ emit iterator
      21
      22      if (citer) call giter2;
      23      call giter1;
      24
      25      cs_internal(csp) = yes;
      26
      27      push2(gtiter, s);
      28      call gseti;
      29
      30      if (citer) call giter3;
      31
      32      return;
      33
      34      end fnct gtiter;
       1 .=member fldbin
       2      subr fldbin(op, a1, a2, success);
       3
       4$ this routine attempts to constant fold 'a1 op a2', and sets
       5$ 'success' to indicate whether it was successful.
       6
       7$ if we are successful, we push the result on astack.
       8
       9$ for the moment the only operations we fold are +, -, *,
      10$ /, and mod on integers whose 'val' entries are only one
      11$ word.
      12
      13$ op, a1, and a2 are all symbol table pointers.
      14
      15      size op(ps);            $ operator name
      16      size a1(ps), a2(ps);    $ operands
      17      size success(1);        $ indicates successful folding
      18
      19      size f1(ps), f2(ps);    $ operand forms
      20      size j(ps);             $ loop index
      21      size len(ps);           $ length of string result
      22      size l1(ps), l2(ps);    $ lengths of val entries, then of strings
      23      size p1(ps), p2(ps);    $ pointers to val entries
      24      size s1(sds_sz);        $ string values
      25      size s2(sds_sz);
      26      size str(sds_sz);
      27      size t(ps);             $ symbol table pointer for result
      28      size v1(ws);            $ integer values
      29      size v2(ws);
      30      real r1, r2;            $ real values
      31
      32
      33      success = no;           $ assume failure
      34
      35      if ( ^ is_const(a1)) return;
      36      if ( ^ is_const(a2)) return;
      37
      38      f1 = form(a1); f2 = form(a2);
      39
      40      if is_fstr(f1) & is_fstr(f2) then
      41          if op = sym_plus then
      42              l1 = vlen(a1); l2 = vlen(a2);
      43              p1 = vptr(a1); p2 = vptr(a2);
      44              do j = 0 to l1-1; .f. 1+j*ws, ws, s1 = val(p1+j); end;
      45              do j = 0 to l2-1; .f. 1+j*ws, ws, s2 = val(p2+j); end;
      46              l1 = slen s1; l2 = slen s2;
      47              len = l1 + l2 + 2; if (len > toklen_lim) return;
      48              str = 0; slen str = len; sorg str = .sds. len + 1;
      49              .ch. 1, str = 1r'; .ch. len, str = 1r';
      50              do j = 1 to l1; .ch.    1+j, str = .ch. j, s1; end do;
      51              do j = 1 to l2; .ch. 1+l1+j, str = .ch. j, s2; end do;
      52              push1(hashst(str)); call gstr; is_read(astack(asp)) = yes;
      53              success = yes;
      54          end if;
      55
      56
      57      elseif is_fint(f1) & is_fint(f2) then
      58          if ( ^ (sym_plus <= op & op <= sym_mod)) return;
      59          v1 = symval(a1); v2 = symval(a2);
      60          assert vlen(a1) = 1; assert vlen(a2) = 1;
      61
      62          go to icase(op) in sym_plus to sym_mod;
      63
      64          /icase(sym_plus)/   v1 = v1 + v2;     go to esaci;
      65          /icase(sym_minus)/  v1 = v1 - v2;     go to esaci;
      66          /icase(sym_mult)/   v1 = v1 * v2;     go to esaci;
smfe 113
smfe 114          /icase(sym_mod)/
smfe 115              if v2 = 0 then
smfe 116                  call ermsg(16, 0); v1 = 0; go to esaci;
smfe 117              end if;
smfe 118              v1 = mod(v1, v2); if (v1 < 0) v1 = v1 + iabs(v2);
smfe 119              go to esaci;
smfb 582
smfb 583          /icase(sym_div)/
smfb 584              if v2 = 0 then
smfb 585                  call ermsg(16, 0); v1 = 0; go to esaci;
smfb 586              end if;
smfb 587              v1 = v1 / v2;
smfb 588              go to esaci;
      69
      70          /icase(sym_slash)/
smfb 589              if v2 = 0 then
smfb 590                  call ermsg(16, 0); r1 = 0.0; go to esacr;
smfb 591              end if;
      71              r1 = float(v1); r2 = float(v2); r1 = r1 / r2;
      72              go to esacr;
      73
      74      /esaci/
      75          push1(getint(v1)); success = yes;
      76
      77
      78      elseif is_freal(f1) & is_freal(f2) then
      79          if ( ^ (sym_plus <= op & op <= sym_slash)) return;
      80          r1 = symval(a1); r2 = symval(a2);
      81          assert vlen(a1) = 1; assert vlen(a2) = 1;
      82
      83          go to rcase(op) in sym_plus to sym_slash;
      84
      85          /rcase(sym_plus)/   r1 = r1 + r2;     go to esacr;
      86          /rcase(sym_minus)/  r1 = r1 - r2;     go to esacr;
      87          /rcase(sym_mult)/   r1 = r1 * r2;     go to esacr;
smfb 592
smfb 593          /rcase(sym_slash)/
smfb 594              if r2 = 0.0 then
smfb 595                  call ermsg(16, 0); r1 = 0.0; go to esacr;
smfb 596              end if;
smfb 597              r1 = r1 / r2;
smfb 598              go to esacr;
      89
      90      /esacr/
      91          t = getsym(0); form(t) = f_real; is_repr(t) = yes;
      92          is_decl(t) = yes; is_read(t) = yes; is_store(t) = yes;
      93          countup(valp, val_lim, 'val'); val(valp) = r1;
      94          vptr(t) = valp; vlen(t) = 1;
      95          push1(t); success = yes;
      96
      97      end if;
      98
      99      end subr fldbin;
       1 .=member foldun
       2      subr foldun(op, a1, success);
       3$
       4$ this routine attempts to constant fold 'op a1', and sets 'success' to
       5$ indicate whether it was successvful.
       6$
       7      size op(ps);            $ operator name
       8      size a1(ps);            $ operand
       9      size success(1);        $ indicates successful folding
      10
      11      size fm(ps);            $ operand form
      12      size str(sds_sz);       $ string value
      13      size t(ps);             $ symbol table pointer for result
      14      size v(ws);             $ integer value
      15      real r;                 $ real value
      16
      17
      18      success = no;           $ assume failure
      19
      20      if ( ^ is_const(a1)) return;
      21
      22      v = symval(a1); fm = form(a1);
      23
      24      if op = sym_minus then
      25          if is_fint(fm) then
      26              assert vlen(a1) = 1;
      27              push1(getint(-v)); success = yes;
      28          elseif is_freal(fm) then
      29              assert vlen(a1) = 1;
      30              r = v; r = -r;
      31              t = getsym(0); form(t) = f_real; is_repr(t) = yes;
      32              is_decl(t) = yes; is_read(t) = yes; is_store(t) = yes;
      33              countup(valp, val_lim, 'val'); val(valp) = r;
      34              vptr(t) = valp; vlen(t) = 1;
      35              push1(t); success = yes;
      36          else
      37              call ermsg(30, a1);
      38          end if;
      39
      40
      41      elseif op = sym_char then
      42          if ^ is_fint(fm) then call ermsg(34, a1); v = 1r ; end if;
      43          if v < 0 ! cssz <= v then call ermsg(34, a1); v = 1r ; end if;
      44          str = 3q' '; .ch. 2, str = v; push1(hashst(str)); call gstr;
      45          is_read(astack(asp)) = yes; success = yes;
      46
      47      end if;
      48
      49      end subr foldun;
       1 .=member foldst
       2      subr foldst(op, n, success);
       3
       4$ this routine performs constant folding on set and tuple formers.
       5$ its arguments are:
       6
       7$ op:      indicates q1_set or q1_tup
       8$ n:       the number of elements
       9$ success: set to true if folding is possible
      10
      11$ if we succeed in folding the set(tuple), we push the result
      12$ onto the stack and set success = true.
      13
      14$ the actual elements are the top n astack entries.
      15
      16      size op(ps),  $ q1_set or q1_tup
      17           n(ps), $ no. of elements
      18           success(1);  $ set if successful
      19
      20      size j(ps),   $ loop index
      21           elmt(ps); $ set element
      22
      23      size genst(ps);  $ generates constant set or tuple
      24
      25      size p(ps);  $ symtab pointer
      26
      27      success = no;   $ assume folding is impossible
      28
      29      if (n >= vlen_lim) return;
      30
      31      do j = 0 to n-1;
      32          elmt = astack(asp-j);
      33          if (^ is_const(elmt)) return;
      34      end do;
      35
      36      success = yes;
      37
      38      p = genst(op, n);
      39      push1(p);
      40
      41
      42      end subr foldst;
       1 .=member blkdec
       2      subr blkdec;
       3
       4$ blkdec is called when we finish compiling each routine. it
       5$ breaks the code fragment for the routine into basic blocks
       6$ and puts it in the form required by the optimizer.
       7
suna  32      size p2(ps);            $ pointer to previous previous instruction
       8      size prev(ps),   $ pointer to previous instruction
       9           now(ps),    $ pointer to current instruction
      10           op(ps);     $ opcode of prev
      11
      12
      13$ iterate over the program, looking for the end of each
      14$ block.
      15
      16$ set prev to point to the routines entry instruction.
      17      prev = prog_start;
      18
      19      while opcode(prev) ^= q1_entry;
      20          prev = next(prev);
      21      end while;
      22
      23$ iterate over the blocks in the routine
      24      while prev ^= 0;
      25
      26$ make blocktab entry
      27
      28          countup(blocktabp, blocktab_lim, 'blocktab');
      29          b_first(blocktabp) = prev;
      30          b_rout(blocktabp) = currout;
      31
      32          blockof(prev) = blocktabp; $ thread first instruction
      33
      34$ set 'now' to point to the instruction after the blocks label.
      35          now = next(prev);
suna  33          p2 = 0;
      36
      37$ look for end of block
smfb 599          while now ^= 0;
smfb 600              op = opcode(now);
smfb 601
smfb 602              if (op = q1_label ! op = q1_tag) quit;
smfb 603
smfb 604              if op = q1_noop then
      49                  if (prev ^= 0) next(prev) = next(now);
      50                  now = next(now);
      51
suna  34              elseif opcode(prev) = q1_goto then
suna  35                  if op = q1_stmt then
suna  36                      assert p2 ^= 0;
suna  37                      next(p2) = now; p2 = now; now = next(now);
suna  38                      next(p2) = prev; blockof(p2) = blocktabp;
suna  39                  else
suna  40                      opcode(now) = q1_noop; now = next(now);
suna  41                  end if;
      52              else
      53                  blockof(now) = blocktabp;
suna  42                  p2 = prev; prev = now; now = next(now);
      57              end if;
      58          end while;
      59
      60$ we now have:
      61
      62$ prev:    points to end of current block
      63$ now:     points to next block if one exists
      64
      65$ the current block must end in with one of the following instructions:
      66
      67$    q1_exit
      68$    q1_goto
      69$    q1_stop
      70
      71$ if it does not end in one of these, there is an implicit
      72$ branch to the next block; we make this explict by inserting
      73$ a 'goto'.
      74
      75$ if this is the routine's stop or exit block, we save a pointer
      76$ to it in routab.
      77
      78          op = opcode(prev);
      79
      80          if op ^= q1_exit & op ^= q1_goto & op ^= q1_stop then
      81              call insert(prev, q1_goto, arg1(now), 0, 0);
      82              blockof(prev) = blocktabp;
      83          end if;
      84
      85          next(prev) = 0;  $ indicate end of list
      86          prev = now;  $ point to label of next block
      87      end while;
      88
      90
      91      end subr blkdec;
       1 .=member genelt
       2      fnct genelt(nam, fm);
       3$
       4$ this routine generates a constant of type element.  nam is the symbol
       5$ table entry for the original constant (or initialised variable), and
       6$ fm is the desired form.
       7$
       8$ if nam is a global, we must allocate a variable whose name depends on
       9$ the name of nam.
      10$
      11      size nam(ps);             $ symbol table pointer for constant
      12      size fm(ps);              $ desired form
      13
      14      size genelt(ps);          $ symbol table pointer returned
      15
      16
      17      genelt = hashst('e$' .cc. symsds(nam));
      18
      19      is_repr(genelt)  = yes;
      20      is_decl(genelt)  = yes;
      21      is_read(genelt)  = yes;
      22      is_store(genelt) = yes;
      23
      24      form(genelt) = fm;
      25
      26      countup(valp, val_lim, 'val');
      27      val(valp) = alias(nam);
      28
      29      vptr(genelt) = valp;
      30      vlen(genelt) = 1;
      31
      32
      33      end fnct genelt;
       1 .=member genst
       2      fnct genst(op, n);
       3
       4$ this routine generates a constant set or tuple and returns a symbol
       5$ table pointer to it.
       6
bnda  41      size op(ps);            $ opcode (q1_set or q1_tup)
bnda  42      size n(ps);             $ number of elements
       9
bnda  43      size genst(ps);         $ symbol table pointer returned
      11
bnda  44      size all_pairs(1);      $ indicates that all elements are pairs
bnda  45      size card(ps);          $ cardinality of result
bnda  46      size done(1);           $ indicates that set elements are sorted
bnda  47      size elmt(ps);          $ symtab pointer for element
bnda  48      size fm(ps);            $ formtab pointer for result
bnda  49      size hashc(ws);         $ hash code
bnda  50      size indx(ps);          $ index into heads
bnda  51      size j(ps), k(ps);      $ loop counters
bnda  52      size temp(ps);          $ temporary astack pointer
bnda  53
bnda  54
bnda  55$ if this is a set former, sort the elements by their symbol table index
bnda  56$ and remove duplicate elements.
bnda  57
bnda  58      if op = q1_set & n > 0 then
bnda  59
bnda  60          $ first sort the set elements using bubble sort.
bnda  61          do j = asp-n+2 to asp;
bnda  62              done = yes;  $ assume that the set elements are sorted.
bnda  63              do k = asp-1 to j-1 by -1;
bnda  64                  if astack(k) > astack(k+1) then
bnda  65                      swap(astack(k), astack(k+1));  done = no;
bnda  66                  end if;
bnda  67              end do k;
bnda  68              if (done) quit do j;
bnda  69          end do j;
bnda  70
bnda  71          $ remove duplicate elements, if any, and adjust the stack.
bnda  72          k = asp - n + 1;
bnda  73          do j = asp-n+1 to asp;
bnda  74              if astack(j) ^= astack(k) then  $ a new element.
bnda  75                  k = k + 1;  astack(k) = astack(j);
bnda  76              end if;
bnda  77          end do j;
bnda  78          card = n - (asp - k);
bnda  79          free_stack(asp - k);  $ remove excess elements.
bnda  80
bnda  81      else    $ op = q1_tup.
bnda  82          card = n;
bnda  83      end if;
bnda  84
bnda  85$ next compute the hash code for the constant.
bnda  86
bnda  87      hashc = 0;
bnda  88      do j = asp-card+1 to asp;
bnda  89          if (alias(astack(j))) astack(j) = alias(astack(j));
bnda  90          hashc = hashc .ex. astack(j);
bnda  91      end do j;
bnda  92      hashc = (.f. 1, ws/2, hashc) .ex. (.f. ws/2+1, ws/2, hashc);
bnda  93
bnda  94$ next seach the clash list for this hash code to see whether another
bnda  95$ set (or tuple) with the same value exists.
bnda  96
bnda  97      indx  = mod(hashc, heads_lim)+1;
bnda  98      genst = heads(indx);
bnda  99      while genst ^= 0;
bnda 100          until 1;  $ exit when not this symtab entry.
bnda 101              if (name(genst) ^= 0) quit until;  $ not non-primitive
bnda 102              if (op = q1_set & is_fset(form(genst)) = no) quit until;
bnda 103              if (op = q1_tup & is_ftup(form(genst)) = no) quit until;
bnda 104              if (vlen(genst) ^= card) quit until;  $ different length
bnda 105              temp = asp - card + 1;  $ first astack entry of constant
bnda 106              do k = 0 to card-1;
bnda 107                  if (astack(temp+k) ^= val(vptr(genst)+k)) quit until;
bnda 108              end do k;
bnda 109
bnda 110              $ found a matching entry:  free the new elements and
bnda 111              $ return the pointer to the old entry.
bnda 112
bnda 113              free_stack(card);
bnda 114              return;
bnda 115
bnda 116          end until 1;
bnda 117          genst = link(genst);
bnda 118      end while;
      18
      19      genst = getsym(0);
      20
      21      is_repr(genst)  = yes;
      22      is_decl(genst)  = yes;
      23      is_read(genst)  = yes;
      24      is_store(genst) = yes;
      25
bnda 119      $ link to front of clash list.
bnda 120      link(genst) = heads(indx);
bnda 121      heads(indx) = genst;
bnda 122
bnda 123$ build the val entry for the set or tuple.  for sets, check whether all
bnda 124$ the elements are pairs, and if so, allocate a map rather than a set.
      26
      27      vptr(genst) = valp + 1;
bnda 125      vlen(genst) = card;
      29
      32
      33      all_pairs = yes;
bnda 126      if (card = 0) all_pairs = no;
      35
bnda 127      do j = asp-card+1 to asp;
bnda 128          elmt = astack(j);
bnda 129          if alias(elmt) then  call ermsg(0, 0);  end if;
      39          if (alias(elmt) ^= 0) elmt = alias(elmt);
      40
      41          fm = form(elmt);
      42
      43          if elmt = sym_om & op = q1_set then
      44              call ermsg(82, 0);
bnda 130          elseif elmt = sym_om then
bnda 131              call warn(6, 0);
      45          elseif ^ is_ftup(fm) ! ft_lim(fm) ^= 2 then
      46              all_pairs = no;
      47          elseif  val(vptr(elmt))   = sym_om  !
      48                  val(vptr(elmt)+1) = sym_om then
      49              all_pairs = no;
      50          end if;
      51
      52          countup(valp, val_lim, 'val');
      53          val(valp) = elmt;
      54      end do;
      55
      56      if op = q1_set then
      57          if all_pairs then
      58              fm = f_umap;
      59          else  $ set
      60              fm = f_uset;
      61          end if;
      62
      63      else   $ tuple
bnda 132          if card = 0 then  $ treat as (homogeneous) null tuple.
      65              push2(f_gen, sym_zero);
      66              call gttup2;
      67
bnda 133          elseif card = 1 then  $ treat as homogeneous tuple.
      69              elmt = astack(asp);
      70
      71              push2(form(elmt), sym_one);
      72              call gttup2;
      73
      74          else  $ treat as mixed tuple
      75              temp = asp;
      76
bnda 134              do j = temp-card+1 to temp;
bnda 135                  elmt = astack(j);
      79                  push1(form(elmt));
      80              end do;
      81
bnda 136              push1(card-2);  $ yes, card - 2.
      83              call gttup1;
      84          end if;
      85
      86          pop1(fm);
      87
      88      end if;
      89
      90      form(genst) = fm;
      91
bnda 137      free_stack(card);  $ pop elements from stack.
      93
      94
      95      end fnct genst;
       1 .=member hash
       2
       3 .+tr  notrace entry;
       4
       5      fnct hash(ara, words);
       6
       7$ this routine hashes a names into symtab. its arguments are:
       8
       9$ ara:    a word size array containing the name, formatted as
      10$         if it were a 'names' entry.
      11
      12$ words:  the number of words in the name
      13
      14      size ara(ws);
      15      dims ara(1);
      16
      17      size words(ps);
      18
      19      size hash(ps);  $ symbol table pointer
      20
      21      size hashc(ws),  $ hash code
      22           indx(ps),  $ index into heads
      23           j(ps),      $ loop index
      24           n(ps);  $ names pointer
      25
      26
      27$ compute hash code
      28      hashc = 0;
      29
      30      do j = 1 to words;
      31          hashc = hashc .ex. ara(j);
      32      end do;
      33
      34      hashc = (.f. 1, ws/2, hashc) .ex. (.f. ws/2+1, ws/2, hashc);
      35
      36$ compute index into array of hash headers and search for
      37$ the name.
      38
      39      indx = mod(hashc, heads_lim) + 1;
      40      hash = heads(indx);
      41
      42      while hash ^= 0;
      43          n = name(hash)-1; $ compare names
      44
      45          do j = 1 to words;
      46              if (names(n+j) ^= ara(j)) go to nxt;
      47          end do;
      48
      49          return;
      50
      51      /nxt/
      52          hash = link(hash);
      53
      54      end while;
      55
      56
      57$ if we reach here, we must make a new symtab entry.
      58
      59      countup(symtabp, symtab_lim, 'symtab');
      60      hash = symtabp;
      61
      62      symtab(hash) = 0;
      63      name(hash)   = namesp + 1;
      64
      65      do j = 1 to words;
      66          countup(namesp, names_lim, 'names');
      67          names(namesp) = ara(j);
      68      end do;
      69
      70$ add to front of clash list
      71      link(hash) = heads(indx);
      72      heads(indx) = hash;
      73
      74
      75      end fnct hash;
       1 .=member hashst
       2      fnct hashst(str1);
       3
       4$ this routine hashes a self defining string into symtab. this is
       5$ done in two steps:
       6
       7$ 1. copy str1 into str2 then set its insignificant bits to
       8$    zero. we do this so that strings can be compared for
       9$    equality useing a simple word by word test.
      10
      11$ 2. convert str2 to 'names array' format and call hash.
      12
      13      size str1(sds_sz);  $ string being hashed
      14
      15      size hashst(ps);        $ symbol table pointer returned
      16
      17      size p(ps),   $ pointer to new names entry
      18           org(ps),  $ sorg of strings
      19           len(ps),  $ slen of strings
      20           extra(ps),  $ number of extra bits
      21           words(ps),  $ length of names entry
      22           j(ps),      $ loop index
      23           str2(sds_sz);  $ duplicate string
      24
      25      size ara(ws);  $ array for string
      26      dims ara(sds_sz/ws);
      27
      28      org = sorg str1;  $ get origin and length
      29      len = slen str1;
      30
      31$ copy string and clear extra bits.
      32      str2 = str1;
      33
      34      extra = org - 1 - .sl. - .so. - len * cs;
      35      .e. 1 + .sl. + .so., extra, str2 = 0;
      36
      37      words = org/ws;
      38
      39$ convert to names format and call hash.
      40      do j = 1 to words;
      41          ara(j) = .f. 1 + (j-1) * ws, ws, str2;
      42      end do;
      43
      44      hashst = hash(ara, words);
      45
      46
      47      end fnct hashst;
       1 .=member hashf1
       2      fnct hashf1(dummy);
       3
       4$ this routine hashes forms which donot use mttab. we begin by
       5$ computing the hash by exclusive-oring pieces of the form.
       6
       7
       8      size hashf1(ps);   $ formtab pointer returned
       9
suna  43      size hashc(ws);         $ hash code.
suna  44      size indx(ps);          $ index into fheads.
suna  45      size j(ps);             $ loop index.
suna  46
      13
      14      hashc = 0;   $ hash code of form
      15
      16      do j = 0 to formtab_sz/ws-1;
      17          hashc = hashc .ex. .f. 1+j*ws, ws, formtab(formtabp);
      18      end do;
      19
      20      hashc = (.f. 1, ws/2, hashc) .ex. (.f. ws/2+1, ws/2, hashc);
      21
      22$ compute index in 'fheads' and get formtab pointer
      23      indx = mod(hashc, fheads_lim) + 1;
      24      hashf1 = fheads(indx);
      25
      26$ look for a matching entry. we compare entries by
      27$ setting ft_link(formtabp) to ft_link(entry being compared)
      28$ then doing a full word comparison.
      29
      30$ note that if we try to hash in f_gen we will always wind up
      31$ building a new formtab entry. this is because a pointer to
      32$ formtab(0) is taken as a null pointer. fortunately, f_gen is
      33$ only hashed in once.
      34
      35      while hashf1 ^= 0;
      36          ft_link(formtabp)  = ft_link(hashf1);
      37          ft_deref(formtabp) = ft_deref(hashf1);
      38
      39          if formtab(formtabp) = formtab(hashf1) then  $ found match
      40              formtabp = formtabp - 1;  $ free new entry
      41              return;
      42          end if;
      43
      44          hashf1 = ft_link(hashf1);
      45      end while;
      46
      47$ add new entry to clash list
      48      ft_link(formtabp) = fheads(indx);
      49      fheads(indx) = formtabp;
      50
      51$ compute the dereferenced form
      52      if ft_type(formtabp) = f_elmt then
      53          if ft_type(ft_base(formtabp)) = f_pbase then
      54              ft_deref(formtabp) = formtabp;
      55          else
smfa  52              ft_deref(formtabp) = ft_deref(ft_elmt(ft_base(formtabp)));
      57          end if;
      58      else
      59          ft_deref(formtabp) = formtabp;
      60      end if;
      61
      62      hashf1 = formtabp;
      63
      64
      65      end fnct hashf1;
       1 .=member hashf2
       2      fnct hashf2(dummy);
       3
       4$ this routine hashes forms which use mttab.
       5$ the new form is at formtab(formtabp).
       6
       7      size hashf2(ps);  $ pointer returned
       8
       9      size type(ps),  $ ft_type
      10           high(ps),  $ ft_lim
      11           elmt(ps);  $ ft_elmt
      12
suna  47      size hashc(ws);         $ hash code.
suna  48      size indx(ps);          $ index into fheads.
suna  49      size el(ps);            $ ft_elmt value.
suna  50      size j(ps);             $ loop index.
      17
      18
      19$ get the ft_type, ft_lim and ft_elmt.
      20
      21      type = ft_type(formtabp);
      22      high = ft_lim(formtabp);
      23      elmt = ft_elmt(formtabp);
      24
      25$ compute the hash as the exclusive or of the type and the mttab
      26$ entries.
      27
      28      hashc = type;
      29
      30      do j = 1 to high;
      31          hashc = hashc .ex. mttab(elmt + j);
      32      end do;
      33
      34      indx = mod(hashc, fheads_lim) + 1; $ get index into table of heade
      35      hashf2 = fheads(indx);
      36
      37$ scan for match
      38      while hashf2 ^= 0;
      39          if (ft_type(hashf2) ^= type) go to nxt;
      40          if (ft_lim(hashf2) ^= high) go to nxt;
      41
      42          el = ft_elmt(hashf2);
      43
      44          do j = 1 to high;
      45              if (mttab(el+j) ^= mttab(elmt+j)) go to nxt;
      46          end do;
      47
      48$ found match. free duplicate entries in formtab and mttab.
      49          formtabp = formtabp - 1;
      50          mttabp = elmt;
      51          return;
      52
      53      /nxt/
      54          hashf2 = ft_link(hashf2);
      55
      56      end while;
      57
      58$ link new entry into clash list
      59      ft_link(formtabp) = fheads(indx);
      60      fheads(indx) = formtabp;
      61
      62$ compute the dereferenced form
      63      if ft_type(formtabp) = f_elmt then
      64          if ft_type(ft_base(formtabp)) = f_pbase then
      65              ft_deref(formtabp) = formtabp;
      66          else
      67              ft_deref(formtabp) = ft_deref(ft_base(formtabp));
      68          end if;
      69      else
      70          ft_deref(formtabp) = formtabp;
      71      end if;
      72
      73      hashf2 = formtabp;
      74
      75
      76      end fnct hashf2;
       1 .=member chkvar
       2      subr chkvar(nam);
       3
       4$ this routine is called after 'nam' is used as a variable. if
       5$ nam has been seen before(is_decl = yes) we check that it is
       6$ not a procedure or member name. otherwise we give it an implicit
       7$ declaration.
       8
       9      size nam(ps);  $ name being checked
      10
      11      if is_decl(nam) then
      12          if (is_proc(nam) ! is_memb(nam)) call ermsg(29, nam);
      13          if ^ is_read(nam) then
      14              if ^ is_local(nam) then
      15                  call ermsg(96, nam);
      16              else
      17                  call ermsg(97, nam);
      18              end if;
      19              is_read(nam)  = yes;
      20          end if;
      21
      22      else
      23          if ( ^ is_local(nam)) call ermsg(03, nam);
      24          if (uv_flag & ^ is_internal(nam)) call warn(4, nam);
      25          is_decl(nam) = yes;
      26          is_read(nam) = yes;
      27          is_write(nam) = yes;
      28          is_store(nam) = yes;
      29
      30          if unit_type = unit_proc & currout ^= sym_main_ then
      31              is_stk(nam) = yes;
      32          else
      33              is_stk(nam) = no;
      34          end if;
      35      end if;
      36
      37
      38      end subr chkvar;
       1 .=member insn
       2      subr insn(i, op, ara, n);
       3
       4$ this routine inserts an instruction after 'i' and advances 'i' to
       5$ point to it. if the instruction defines a temporary, it also
       6$ sets 'tprev' and 'tlast' for the temporary.
       7
       8$ the arguments are:
       9
      10$ i:       insert new instruction here
      11$ op:      opcode q1_xxx
      12$ ara:     array of arguments
      13$ n:       number of arguments
      14
      15      size i(ps),   $ pointer to instruction
      16           op(ps),  $ opcode
      17           ara(ps),  $ array of arguments
      18           n(ps);     $ no. of arguments
      19      size p(ps);             $ pointer into argtab
      20
      21      dims ara(1);  $ dummy dimension
      22
      23      size j(ps),   $ loop index
      24           prev(ps), $ pointer to previous instruction
      25           in(ps);   $ name of input
      26
      27$ the variables 'prev1' and 'last1' delimit the code fragment for the
      28$ inputs. the function 'after' is used to tell if one instruction is
      29$ after another.
      30
      31      size prev1(ps),
      32           last1(ps);
      33
      34      size after(1);
      35
      36
      37$ begin by building the new instruction.
      38
      39      countup(codetabp, codetab_lim, 'codetab');
      40
      41      codetab(codetabp) = 0;
      42
      43      opcode(codetabp) = op;
      44      nargs(codetabp)  = n;
      45      argp(codetabp)   = argtabp;
      46
      47$ add arguments to argtab.
      48
      49      p       = argtabp;      $ save current position in argtab
      50      argtabp = argtabp + n;  $ get extra space
      51      if (argtabp > argtab_lim) call overfl('argtab');
      52
      53      do j = 1 to n;
      54          argtab(p+j) = ara(j);
      55      end do;
      56
      57$ next link new instruction into code list
      58      next(codetabp) = next(i);
      59      next(i) = codetabp;
      60
      61$ advance 'i'
      62      prev = i;
      63      i = codetabp;
      64
      65$ if 'op' doesnt define a temporary, we are done.
      66      if (^ (defs_temp(op) & is_temp(ara(1)))) return;
      67
      68$ otherwise find the code fragment for the inputs.
      69
      70      prev1 = 0;    $ initialize
      71      last1 = 0;
      72
      73      do j = 2 to n;
      74          in = ara(j);
      75
      76          if ^ is_temp(in) then
      77              cont;
      78
      79          elseif prev1 = 0 then  $ first temporary seen
      80              prev1 = tprev(in);
      81              last1 = tlast(in);
      82
      83          elseif after(tprev(in), last1) then  $ -in- is last input
      84              last1 = tlast(in);
      85
      86          elseif after(prev1, tlast(in)) then  $ -in- is first input
      87              prev1 = tprev(in);
      88          end if;
      89      end do;
      90
      91      if (prev1 = 0) prev1 = prev;  $ use previous instruction
      92
      93      tprev(ara(1)) = prev1;
      94      tlast(ara(1)) = i;
      95
      96
      97      end subr insn;
       1 .=member after
       2      fnct after(i1, i2);
       3
       4$ this function returns true if either:
       5
       6$ 1. i1 and i2 point to the same instruction
       7$ 2. i1 occurs after i2 in the code.
       8
       9$ we simply scan the code starting from i2 until we reach i1 or the
      10$ end of the program.
      11
      12      size i1(ps),  $ code pointers
      13           i2(ps);
      14
      15      size after(1);  $ flag returned
      16
      17      size p(ps);     $ code pointer
      18
      19      p = i2;
      20
      21      while 1;
      22          if (p = i1) go to pass;   $ i2 is first
      23          if (p = 0)  go to fail;   $ i1 is first
      24
      25          p = next(p);
      26      end while;
      27
      28/pass/
      29
      30      after = yes;
      31      return;
      32
      33/fail/
      34
      35      after = no;
      36      return;
      37
      38      end fnct after;
       1 .=member insert
       2      subr insert(i, op, a1, a2, a3);
       3
       4$ this is a version of 'insn' for handling opcodes with up to
       5$ three arguments. the map 'numargs' tells us how many arguments
       6$ are actually supplied for each opcode.
       7
       8      size i(ps),  $ pointer to instruction
       9           op(ps), $ opcode
      10           a1(ps), $ arguments
      11           a2(ps),
      12           a3(ps);
      13
      14      size ara(ps);  $ array for arguments
      15      dims ara(3);
      16
      17      ara(1) = a1;   $ pack arguments into array.
      18      ara(2) = a2;
      19      ara(3) = a3;
      20
      21      call insn(i, op, ara, numargs(op));
      22
      23
      24      end subr insert;
       1 .=member emitn
       2      subr emitn(op, ara, n);
       3
       4$ this routine is similar to 'insn', but adds the new instruction at the
       5$ end of the program.
       6
       7      size op(ps),  $ opcode
       8           ara(ps), $ array of arguments
       9           n(ps);      $ number of arguments
      10
      11      dims ara(1);  $ dummy dimension
      12
      13      call insn(prog_end, op, ara, n);
      14
      15
      16      end subr emitn;
       1 .=member emit
       2      subr emit(op, a1, a2, a3);
       3
       4$ this is a variation of 'insert' which adds an instruction to the
       5$ end of the program.
       6
       7      size op(ps),  $ opcode
       8           a1(ps),  $ arguments
       9           a2(ps),
      10           a3(ps);
      11
      12      call insert(prog_end, op, a1, a2, a3);
      13
      14
      15      end subr emit;
       1 .=member movblk
       2
       3 .+tr  trace entry;
       4
       5      subr movblk(prev, last, targ);
       6
       7$ this routine moves a block of code. its arguments are:
       8
       9$ prev: points to instruction before block to be moved
      10$ last: points to end of block to be moved
      11$ targ: insert block after this instruction
      12
      13$ note that if we are moving code from or to the end of the program,
      14$ we must reset 'prog_end'. for this reason prog_end itself should
      15$ not be used as an argument to the routine.
      16
      17
      18      size prev(ps),  $ previous instruction to block
      19           last(ps),  $ last instruction of block
      20           targ(ps);  $ target
      21
      22      size first(ps),  $ first instruction of block
      23           j(ps);  $ loop index
      24
      25
      26      if trs_flag then  $ provide trace
smfe 120          put ,skip ,'entering movblk at ' :symsds(curmemb),a
smfe 121              ,'.' :symsds(currout),a ,'.' :stmt_count,i
smfe 122              ,': ' :prev:last:targ,nil ,skip;
      32
      33          stack_trace('astack ', asp);
      34          call prgdmp;
      35      end if;
      36
      37
      38      if (prev = last) return;  $ null block
      39
      40      if (prev = targ) return; $ already in place
      41
      42      if (last = targ) return; $ already in place
      43
      44      first = next(prev);  $ pointer to start of block
      45
      46      next(prev) = next(last);
      47      next(last) = next(targ);
      48      next(targ) = first;
      49
      50      if prog_end = last then $ moving code from end of program
      51          prog_end = prev;
      52
      53      elseif prog_end = targ then $ moving code to end of program
      54          prog_end = last;
      55      end if;
      56
      57$ adjust all 'tprev' fields which point to prev, last, or targ.
      58
      59      do j = symtab_org+1 to symtabp;
      60          if tprev(j) = prev then
      61              tprev(j) = targ;
      62
      63          elseif tprev(j) = last then
      64              tprev(j) = prev;
      65
      66          elseif tprev(j) = targ then
      67              tprev(j) = last;
      68          end if;
      69      end do;
      70
      71
      72      end subr movblk;
       1 .=member killexp
       2      subr killex(e);
       3
       4$ this routine deletes the code fragment for an expression 'e'.
       5$ we assume that 'e' is dead and that there are no pointers
       6$ from cstack to the code fragment we are deleting.
       7
       8
       9      size e(ps);   $ the expression
      10
      11      size prev(ps),  $ its tprev
      12           last(ps);
      13
      14
      15      if (^ is_temp(e)) return;
      16
      17      prev = tprev(e);
      18      last = tlast(e);
      19
      20      next(prev) = next(last);
      21
      22      if (prog_end = last) prog_end = prev;
      23
      24
      25      end subr killex;
       1 .=member copy
       2      fnct copy(exp);
       3
       4$ this routine copies the code fragment for an expression 'exp'.
       5
       6$ typically copy is called to process 'f(e1) with x'. this statement
       7$ is processed in three steps:
       8
       9$ 1. emit the binary operator 't := f(e1) with x'.
      10$ 2. copy the code fragment for 'f(e1)'.
      11$ 3. use the copy to emit 'f(e1) := t'.
      12
      13$ if we were to do a complete copy of the code fragment for 'f(e1)'
      14$ we would wind up evaluating 'e1' twice. this is undesirable.
      15
      16$ instead of doing a full copy, we change the original code fragment
      17$ to 'f(t1 := e1)' and return 'f(t1)'.
      18
      19$ note that we expect 'exp' to be a valid left hand side.
      20
      21
      22$ copy works by making two passes over the code for 'exp'. during
      23$ the first pass we modify the original code fragment and mark those
      24$ instructions which will eventually have to be copied. this is
      25$ done using a workpile technique.
      26
      27$ during the second pass we iterate forward through the code copying
      28$ all necessary instructions.
      29
      30$ rather than add a special field to indicate which instructions must
      31$ be copied, we use the 'sflag' field. this field is otherwise
      32$ unused during the semantic pass.
      33
      34
      35      size exp(ps);    $ temporary for original expression
      36
      37      size copy(ps);   $ symtab pointer returned
      38
      39      size e(ps);    $ local copy of 'exp'
      40
      41      size last(ps), $ tlast(e)
      42           op(ps),   $ opcode defining 'e'
      43           arg(ps),  $ argument
      44           p(ps),    $ code pointer
      45           t(ps),    $ temporary
      46           i(ps),    $ instruction
      47           j(ps);    $ loop index
      48
      49      size ara(ps);  $ array of argumments
      50      dims ara(nargs_lim);
      51
      52      size savep(ps);  $ saved astack pointer
      53
      54      size subst(ps);  $ does name substitution
      55
      56$ when we copy an instruction we must allocate a new temporary
      57$ for its result. the array 'ctab' maps temporaries in the original
      58$ expression into temporaries in the copy.
      59
      60      nameset ctab;
      61          +*  ctab_lim   = 100  **   $ dimension of ctab
      62
      63          size ctab(32);
      64          dims ctab(ctab_lim);
      65
      66          size ctabp(ps);  $ pointer to last entry
      67
      68          +*  old(i)   =  .f. 01, 16, ctab(i)     **  $ original name
      69          +*  new(i)   =  .f. 17, 16, ctab(i)     **  $ new name
      70      end nameset;
      71
      72
      73$ if 'exp' is a variable we simply return it.
      74      if ^ is_temp(exp) then
      75          copy = exp;
      76          return;
      77      end if;
      78
      79$ otherwise use a workpile technique to iterate backwards through the
      80$ code fragment.
      81
      82      savep = asp;
      83      push1(exp);
      84
      85      until savep = asp;
      86          pop1(e);
      87
      88          last = tlast(e);
      89          op   = opcode(last);
      90
      91          if op = q1_tup then   $ [a, b] - push 'a' and 'b'
      92              do j = 2 to nargs(last);
      93                  arg = argn(last, j);
      94
      95                  if is_temp(arg) then
      96                      push1(arg);
      97                  end if;
      98              end do;
      99
     100              sflag(last) = yes;
     101
     102          elseif sinmap(op) ^= 0 then   $ f(x), etc.
     103
     104$ if 'f' is a temporary then it is the result of some outer level
     105$ retreival, so we push it on the stack.
     106              if is_temp(arg2(last)) then
     107                  push1(arg2(last));
     108              end if;
     109
     110              call reuse(last, 3);   $ indicate indices are used twice
     111              if (op = q1_subst) call reuse(last, 4);
     112
     113              sflag(last) = yes;
     114
     115          else           $ all other operators are illegal
     116              call ermsg(18, 0);
     117
     118              asp  = savep;
     119              copy = sym_om;
     120
     121              return;
     122          end if;
     123      end until;
     124
     125
     126$ iterate forward copying instructions.
     127
     128      ctabp = 0;
     129
     130      p = next(tprev(exp));     $ first instruction
     131
     132      while 1;
     133          if sflag(p) then
     134              sflag(p) = no;    $ reset
     135
     136              t = gettmp(0);  $ get temp and store in 'ctab'
     137
     138              countup(ctabp, ctab_lim, 'copy');
     139
     140              old(ctabp) = arg1(p);
     141              new(ctabp) = t;
     142
     143              ara(1) = t;     $ build array of arguments
     144
     145              do j = 2 to nargs(p);
     146                  arg = argn(p, j);
     147                  if (is_temp(arg)) arg = subst(arg);
     148
     149                  ara(j) = arg;
     150              end do;
     151
     152              call emitn(opcode(p), ara, nargs(p));
     153
     154          end if;
     155
     156          if (p = tlast(exp)) quit;
     157          p = next(p);
     158      end while;
     159
     160      copy = subst(exp);
     161
     162
     163      end fnct copy;
       1 .=member subst
       2
       3 .+tr  notrace entry;
       4
       5      fnct subst(nam);
       6
       7$ this routine is called from 'copy' to perform name substitution.
       8
       9      size nam(ps);   $ name of original temporary or label
      10
      11      size subst(ps);  $ new name returned
      12
      13      size j(ps);  $ loop index
      14
      15      access ctab;
      16
      17$ iterate over ctab, looking for an occurrence of 'nam'.
      18      do j = 1 to ctabp;
      19          if old(j) = nam then
      20              subst = new(j);
      21              return;
      22          end if;
      23      end do;
      24
      25      macdrop(old)
      26      macdrop(new);
      27
      28      end fnct subst;
       1 .=member reuse
       2      subr reuse(i, j);
       3
       4$ this routine is called when we find out that 'argn(i, j)' will be
       5$ used twice.
       6
       7$ we begin by setting arg = argn(i, j). if arg is a variable or constant
       8$ we return. otherwise arg is a temporary, and can only be used once.
       9$ we generate an internal variable 't', insert an assignment 't := arg'
      10$ after tlast(arg) and set argn(i, j) = t.
      11
      12      size i(ps),    $ instruction number
      13           j(ps);    $ argument number
      14
      15      size arg(ps),  $ argument name
      16           t(ps),    $ internal variable
      17           p(ps);    $ code pointer to tlast(arg)
      18
      19      arg = argn(i, j);
      20
      21      if (^ is_temp(arg)) return;
      22
      23      t = getvar(0);
      24
      25      p = tlast(arg);
      26      call insert(p, q1_asn, t, arg, 0);
      27
      28      argn(i, j) = t;
      29
      30
      31      end subr reuse;
       1 .=member eqexp
       2      fnct eqexp(e1, e2);
       3
       4$ this function returns true if two expressions are obviously
       5$ equal, i.e. if they have code fragments which are identical
       6$ except for temporary names.
       7
       8$ expressions are considered unequal if they contain operations
       9$ which fall into one of four categories:
      10
      11$ 1. operations which are nondeterministic
      12$ 2. assignments
      13$ 3. iterative set or tuple formers
      14$ 4. labels. these occur in expr blocks, quantifiers, etc.
      15
      16$ eqexp is called by fndinc in order to determine that the
      17$ iterator (! i := e1, e1+1, ...) has a constant increment.
      18
      19      size e1(ps),    $ original expressions
      20           e2(ps);
      21
      22      size eqexp(1);  $ flag returned
      23
      24      size a1(ps),    $ copies of arguments
      25           a2(ps);
      26
      27      size i1(ps),     $ tlast(a1)
      28           i2(ps);     $ tlast(a2);
      29
      30      size j(ps),     $ loop index
      31           op(ps),    $ opcode
      32           n(ps);     $ number of arguments
      33
      34      size savep(ps);   $ saved astack pointer
      35
      36$ we consider expressions unequal if they contain any of the
      37$ following operators:
      38
      39      size bad_op(ps);
      40      dims bad_op(8);
      41
      42      data bad_op =
      43           q1_rand, q1_newat, q1_time, q1_date,
      44           q1_set1, q1_tup1, q1_asn, q1_label;
      45
      46      savep = asp;
      47
      48      push2(e1, e2);
      49
      50      until asp = savep;
      51          pop2(a2, a1);
      52
      53          if (a1 = a2) cont;   $ same variable
      54
      55          if (^ is_temp(a1) ! ^ is_temp(a2)) go to fail;
      56
      57          i1 = tlast(a1);
      58          i2 = tlast(a2);
      59
      60          op = opcode(i1);
      61          n  = nargs(i1);
      62
      63          if (op ^= opcode(i2)) go to fail;
      64          if (n ^= nargs(i2))   go to fail;
      65
      66$ if op is nondeterministic or modifies any variables, go to fail
      67
      68          do j = 1 to 8;
      69              if (op = bad_op(j)) go to fail;
      70          end do;
      71
      72$ otherwise scan inputs recursively
      73          do j = 2 to n;
      74              a1 = argn(i1, j);
      75              a2 = argn(i2, j);
      76
      77              push2(a1, a2);
      78          end do;
      79
      80      end until;
      81
      82/pass/    $ equal expressions
      83
      84      eqexp = yes;
      85      return;
      86
      87
      88/fail/    $ unequal expressions
      89
      90      asp = savep;   $ restore stack
      91
      92      eqexp = no;
      93      return;
      94
      95      end fnct eqexp;
       1 .=member gettmp
       2      fnct gettmp(dummy);
       3
       4$ this routine returns a pointer to a new temporary
       5      size gettmp(ps);
       6
       7      gettmp = getsym(0);
       8
       9      is_temp(gettmp)  = yes;
      10      is_stk(gettmp)   = yes;
      11      is_store(gettmp) = yes;
      12      is_read(gettmp)  = yes;
      13      is_write(gettmp) = yes;
      14
      15
      16      end fnct gettmp;
       1 .=member getvar
       2      fnct getvar(dummy);
       3
       4$ this routine returns a symtab pointer to an internally generated
       5$ variable.
       6
       7      size getvar(ps);
       8
       9      getvar = getsym(0);
      10
      11      is_stk(getvar)   = yes;
      12      is_store(getvar) = yes;
      13      is_read(getvar)  = yes;
      14      is_write(getvar) = yes;
      15
      16
      17      end fnct getvar;
       1 .=member getglb
       2      fnct getglb(var);
       3
       4$ this routine allocates a new global variable. it is similar to
       5$ getvar except that the name of the new variable is calculated from
       6$ the name of a program variable. this allows us to refer to the new
       7$ variable in separate compilations.
       8
       9
      10      size var(ps);           $ original variable
      11
      12      size getglb(ps);        $ symbol table pointer returned
      13
      14      size nam(sds_sz);       $ variable name as character string
      15
      16
      17      nam = 'g$' .cc. symsds(var);
      18      getglb = hashst(nam);
      19
      20      is_stk(getglb)   = yes;
      21      is_store(getglb) = yes;
      22      is_read(getglb)  = yes;
      23      is_write(getglb) = yes;
      24
      25
      26      end fnct getglb;
       1 .=member getint
       2      fnct getint(n);
       3
       4$ this routine generates a symbol table pointer to the integer
       5$ 'n'. we get a new name, then make a val entry for it.
       6
       7      size n(ws);             $ integer value
       8
       9      size getint(ps);        $ symbol table pointer returned
      10
      11      size fm(ps);            $ form of result
      12      size j(ps);             $ index
      13      size org(ps);           $ sorg of string
      14      size len(ps);           $ slen of string
      15      size str(sds_sz);       $ integer denotation string
      16      size v1(ws);            $ temporary integer values
      17      size v2(ws);
      18      size v3(ws);
      19
      20
      21      if n >= 0 & n <= 9 then  $ use standard symtab entry
      22          getint = sym_zero + n;
      23          return;
      24      end if;
      25
      26$ otherwise build new entry
      27      if     n > 0 then v1 = n;  len = 0;
      28      elseif n < 0 then v1 = -n; len = 1;
      29      else assert 0;
      30      end if;
      31
      32      v2 = v1 / 10; v3 = 1; len = len + 1;
      33      while v2 > 0; v2 = v2 / 10; v3 = v3 * 10; len = len + 1; end;
      34
      35      org = .sds. len + 1; str = 0; slen str = len; sorg str = org;
      36      if n < 0 then .f. org-cs, cs, str = 1r-; j = 2; else j = 1; end;
      37
      38      while v3 > 0;
      39          .f. org-j*cs, cs, str = charofdig(v1/v3);
      40          v1 = v1 - (v1 / v3) * v3; v3 = v3 / 10; j = j + 1;
      41      end while;
      42
      43      getint = hashst(str); is_read(getint) = yes;
      44
      45      if is_decl(getint) then
      46          if ( ^ is_const(getint)) call ermsg(0, getint);
      47          if (n ^= symval(getint)) call ermsg(0, getint);
      48          return;
      49      end if;
      50
      51      if 0 <= n & n <= maxsi then fm = f_sint; else fm = f_int; end;
      52      form(getint) = fm; is_decl(getint)  = yes; is_repr(getint)  = yes;
      53      is_store(getint) = yes;
      54      countup(valp, val_lim, 'val'); val(valp) = n;
      55      vptr(getint) = valp; vlen(getint) = 1;
      56
      57
      58      end fnct getint;
       1 .=member getlab
       2      fnct getlab(dummy);
       3
       4$ this routine returns a pointer to a new label
       5
       6
       7      size getlab(ps);
       8
       9
      10      getlab = getsym(0);
      11
      12      is_decl(getlab) = yes;
      13      is_repr(getlab) = yes;
      14      form(getlab)    = f_lab;
      15
      16
      17      end fnct getlab;
       1 .=member deflab
       2      subr deflab(lab);
       3
       4$ this routine defines a label. we begin by checking whether the
       5$ label has already been seen. if so, we issue a diagnostic; otherwise
       6$ we emit a q1 label instruction and build a val entry for the label.
       7
       8      size lab(ps);  $ symtab pointer for label
       9
      10      if is_seen(lab) then
      11          call ermsg(33, lab);
      12
      13      else
      14          is_seen(lab) = yes;
      15
      16          call emit(q1_label, lab, 0, 0);
      17
      18          countup(valp, val_lim, 'val');  $ make val entry
      19          val(valp) = prog_end;   vptr(lab) = valp;   vlen(lab) = 1;
      20      end if;
      21
      22
      23      end subr deflab;
       1 .=member deftag
       2      subr deftag(tag);
       3
       4$ this routine defines a case tag. it is similar to deflab except
       5$ that it emits a q1_tag instruction.
       6
       7      size tag(ps);  $ symtab pointer for tag
       8
       9      if is_seen(tag) then
      10          call ermsg(33, tag);
      11
      12      else
      13          is_seen(tag) = yes;
      14
      15          call emit(q1_tag, tag, 0, 0);
      16
      17          countup(valp, val_lim, 'val');  $ make val entry
      18          val(valp) = prog_end;   vptr(tag) = valp;   vlen(tag) = 1;
      19      end if;
      20
      21
      22      end subr deftag;
       1 .=member getsym
       2      fnct getsym(dummy);
       3
       4$ this routine returns a pointer to a new symbol table entry.
       5
       6      size getsym(ps);  $ pointer returned
       7
       8      countup(symtabp, symtab_lim, 'symtab');
       9      getsym = symtabp;
      10
      11      symtab(getsym) = 0;
      12
      13
      14      end fnct getsym;
       1 .=member findlp
       2      fnct findlp(n);
       3
       4$ this routine finds the cstack entry for a 'quit' or 'continue'
       5$ statement and returns a pointer to it. 'n' is an integer which
       6$ has the following significance:
       7
       8$ if n = 0, we return a pointer to the innermost iterator which appears
       9$ explicitly in the program. this ignores iterators for f[x] and +/s
      10$ operations.
      11
      12$ if n ^= 0 then we are processing a statement of the form 'cont '. in this case we return a pointer to the n-th entry
      14$ from the top of cstack, excluding internal iterators and
      15$ .
      16
      17$ note that the parser has already checked that the appropriate
      18$ cstack entry exists.
      19
      20$ as we probe through cstack, we see whether we are passing any
      21$ entries for 'expr' blocks. if so, we are illegally jumping out
      22$ of an expr block, and we issue a diagnostic.
      23
      24      size n(ps);
      25
      26      size findlp(ps);        $ cstack pointer returned
      27
      28      size j(ps);             $ loop index
      29      size tp(ps);            $ cs_type
      30      size count(ps);         $ number of entries found so far
      31
      32
smfa  53      findlp = 0;
smfa  54
      33      if n = 0 then           $ find innermost explicit loop
      34          do j = csp to 1 by -1;
      35              tp = cs_type(j);
      36
      37              if tp = cs_eblk then
      38                  call ermsg(42, 0);
      39              elseif cs_internal(j) then
      40                  cont;
      41              elseif tp = cs_iter ! cs = cs_citer then
smfb 606                      findlp = j;
      42                  quit;
      43              end if;
      44          end do;
      47
      48      else                    $ find i-th entry
      49          count = 0;
      50
      51          do j = csp to 1 by -1;
      52              tp = cs_type(j);
      53
      54              if tp = cs_eblk then
      55                  call ermsg(42, 0);
      56              elseif tp = cs_iter & ^ cs_internal(j) then
      57                  count = count + 1;
smfb 607                      if count = n then findlp = j; quit do; end if;
      59              end if;
      60
      61          end do;
      64      end if;
      65
      66
      67      end fnct findlp;
       1 .=member symsds
       2      fnct symsds(p);
       3
       4$ this routine returns the name of a symbol table entry as a self
       5$ defining string. if p is an internal symbol we return txxxx
       6$ where 'xxx' is the value of p.
       7
       8      size p(ps);   $ symbol table pointer
       9
      10      size symsds(sds_sz),
      11           namsds(sds_sz);    $ gets string from names ptr
      12
      13      size n(ps),    $ integer to be converted
      14           j(ps);  $ loop index
      15
      16      if p = 0 then
      17          symsds = '';
      18
      19      elseif name(p) ^= 0 then
      20          symsds = namsds(name(p));
      21
      22      else
      23          symsds = 't' .pad. 5;
      24
      25          n = p;
      26
      27          do j = 5 to 2 by -1;
      28              .ch. j, symsds = charofdig(mod(n, 10));
      29              n = n/10;
      30          end do;
      31      end if;
      32
      33
      34      end fnct symsds;
       1 .=member namsds
       2      fnct namsds(nam);
       3
       4$ this routine converts a names entry to an sds string.
       5
       6      size nam(ps);  $ pointer to names entry
       7
       8      size namsds(sds_sz);
       9
      10      size j(ps),  $ loop index
      11           words(ps);  $ number of words in names entry
      12
      13      if (nam = 0) go to error;
      14
      15      words = n_sorg(nam)/ws;
      16      if (words = 0) go to error;
      17
      18      do j = 0 to words-1;
      19          .f. 1+j*ws, ws, namsds = names(nam+j);
      20      end do;
      21
      22      return;
      23
      24/error/
      25
      26      namsds = '';
      27
      28      return;
      29
      30
      31      end fnct namsds;
       1 .=member gsave
       2
       3 .+tr  trace entry;
       4
       5      subr gsave;
       6
       7$ this routine is called at the start of a unit. it
       8$ saves the current values of namesp, symtabp, and valp on the
       9$ stack so that we can later free the table space used by
      10$ the unit.
      11
      12      push3(namesp, symtabp, valp);
      13
      14
      15      end subr gsave;
       1 .=member greset
       2      subr greset;
       3
       4$ this routine is called at the end of a procedure, etc. to
       5$ restore the symbol table to its saved state. it also
       6$ reinitializes the code tables.
       7
       8      size j(ps),  $ loop index
       9           p(ps);  $ symbol table pointer
      10
      11$ if astack is wrong at this point it can be a disaster, so we are
      12$ prepared to dump it.
      13      if trs_flag then
      14          stack_trace('greset - before pop', asp);
      15      end if;
      16
      17$ reset pointers
      18      pop3(valp, symtabp, namesp);
      19
      20      names_org  = namesp;  $ reset origins
      21      symtab_org = symtabp;
      22      val_org    = valp;
      23
      24$ delete freed symtab entries from their clash lists. note that the f
      25$ freed entries are at the beginning of their clash list.
      26
      27      do j = 1 to heads_lim;
      28          p = heads(j);
      29
      30          while p > symtabp;
      31              p = link(p);
      32          end while;
      33
      34          heads(j) = p;
      35      end do;
      36
      37      call incode;   $ reinitialize code tables
      38
      39
      40      end subr greset;
       1 .=member gputtb
       2      subr gputtb;
       3
       4$ this routine writes out a page of q1.
       5
       6      size j(ps);             $ loop index
       7$
       8$ before we write out the scope, we check, if so requested, whether all
       9$ user-defined variables have been given data structure declarations.
      10$
smfb 608      if unit_type ^= unit_sys & rpr_flag ^= 0 & ur_flag ^= 0 then
      12          do j = symtab_org + 1 to symtabp;
      13              if (is_internal(j)) cont;
      14              if (is_repr(j))     cont;
      15              call warn(05, j);
      16          end do;
      17      end if;
      18
      19      if (q1sd_flag) call sdump;
      20      if (q1cd_flag) call q1dump;
      21
      22      if .len. sq1_title then call sputtb; else call lputtb; end if;
      23
      24      +* update(org, p, max)  =
      25          org = p;   if (max < p) max = p;
      26          **
      27
      28      update(mttab_org,     mttabp,     mttab_max)
      29      update(formtab_org,   formtabp,   formtab_max)
      30      update(names_org,     namesp,     names_max)
      31      update(val_org,       valp,       val_max)
      32      update(symtab_org,    symtabp,    symtab_max)
      33      update(blocktab_org,  blocktabp,  blocktab_max)
      34      update(argtab_org,    argtabp,    argtab_max)
      35      update(codetab_org,   codetabp,   codetab_max)
      36
      37      macdrop(update)
      38
      39
      40      end subr gputtb;
       1 .=member lputtb
       2      subr lputtb;
       3
       4$ this routine writes a page of q1 onto the little q1 file.
       5
       6
       7      write q1_file, unit_type, symsds(curunit), curunit,
       8          proctabp, ustmt_count, estmt_count;
       9
      10      +* putr(ara, org, last) =  $ write table slice
      11          write q1_file, org, last;
      12          if (org < last) write q1_file, ara(org+1) to ara(last);
      13          **
      14
      15      putr(mttab,    mttab_org,    mttabp)
      16      putr(formtab,  formtab_org,  formtabp)
      17      putr(names,    names_org,    namesp)
      18      putr(val,      val_org,      valp)
      19      putr(symtab,   symtab_org,   symtabp)
      20      putr(blocktab, blocktab_org, blocktabp)
      21      putr(argtab,   argtab_org,   argtabp)
      22      putr(codetab,  codetab_org,  codetabp)
      23
      24      macdrop(putr);
      25
      26
      27      end subr lputtb;
       1 .=member sputtb
       2      subr sputtb;
       3
       4$ this routine writes a page of q1 onto setl q1 file.
       5
       6
       7 .+sq1.
       8
       9      size fm(ps);            $ form
      10      size putbhdrblk(ws);    $ binary header word
      11      size i(ps);             $ loop index
      12      size j(ps);             $ inner loop index
      13
      14      +* putbhdr(t, v)  =     $ write binary header block
      15          putbhdrblk         = 0;
      16          bh_typ_ putbhdrblk = t;
      17          bh_val_ putbhdrblk = v;
      18          write sq1_file, putbhdrblk;
      19          **
      20
      21      +* putbdat(v)  =        $ write one word binary data block
      22          write sq1_file, v;
      23          **
      24
      25
      26$
      27$ unit identifying record
      28$
      29      call putsbi(unit_type);
      30      call putsbs(curunit);
      31      call putsbi(curunit);
      32      call putsbi(proctabp);
      33      call putsbi(ustmt_count);
      34      call putsbi(estmt_count);
      35$
      36$ form table
      37$
      38      call putsbi(formtab_org);   call putsbi(formtabp);
      39
      40      do i = formtab_org+1 to formtabp;
      41          putbhdr(bt_tuple, 0)
      42
      43          call putsbi(ft_type(i));
      44          call putsbi(ft_mapc(i));
      45          call putsbi(ft_elmt(i));
      46          call putsbi(ft_dom(i));
      47          call putsbi(ft_im(i));
      48          call putsbi(ft_imset(i));
      49          call putsbi(ft_base(i));
      50          call putsbi(ft_deref(i));
      51          call putsbi(ft_low(i));
      52          call putsbi(ft_lim(i));
      53          call putsbi(ft_pos(i));
      54          call putsbb(ft_hashok(i));
      55          call putsbb(ft_neltok(i));
      56
      57          putbhdr(bt_tuple, 0)
      58
      59          if ft_type(i) = f_mtuple ! ft_type(i) = f_proc then
      60              do  j = 1 to ft_lim(i);
      61                  call putsbi(mttab(ft_elmt(i)+j));
      62              end do;
      63
      64          elseif is_fbase(i) then
      65              call putsbi(ft_num(i, f_lset));
      66              call putsbi(ft_num(i, f_lmap));
      67              call putsbi(ft_num(i, f_lpmap));
      68              call putsbi(ft_num(i, f_limap));
      69              call putsbi(ft_num(i, f_lrmap));
      70
      71          elseif is_fmap(i) & is_frem(i) then
      72              call putsbi(ft_tup(i));
      73          end if;
      74
      75          putbhdr(bt_tuple, 1)
      76
      77          putbhdr(bt_tuple, 1)
      78      end do;
      79$
      80$ symbol table
      81$
      82      call putsbi(symtab_org);   call putsbi(symtabp);
      83
      84      do i = symtab_org+1 to symtabp;
      85          putbhdr(bt_tuple, 0)
      86
      87          call putsbs(i); $ write name or null string
      88          call putsbi(form(i));
      89          call putsbi(alias(i));
      90          call putsbb(is_repr(i));
      91          call putsbb(is_temp(i));
      92          call putsbb(is_stk(i));
      93          call putsbb(is_read(i));
      94          call putsbb(is_write(i));
      95          call putsbb(is_param(i));
      96          call putsbb(is_store(i));
      97          call putsbb(is_init(i));
      98          call putsbb(is_seen(i));
      99          call putsbb(is_back(i));
     100          call putsbb(is_rec(i));
     101
     102          fm = form(i);
     103
     104          if vptr(i) ^= 0 then
     105              call putsbb(yes);   $ has_value_ in setl.opt = true
     106              call putsbi(vlen(i));
     107
     108              putbhdr(bt_tuple, 0)
     109
     110              if is_fint(fm) then
     111                  call putsbi(val(vptr(i)));
     112
     113              elseif is_freal(fm) then
     114                  call putsbr(val(vptr(i)));
     115
     116              elseif is_fstr(fm) then
     117                  call putsbs(-i);
     118
     119              elseif ft_type(fm) = f_atom then
     120                  $ recall that booleans are represented by the short
     121                  $ atoms 0 and maxsi, resp.
     122                  if     val(vptr(i)) = 0     then call putsbb(yes);
     123                  elseif val(vptr(i)) = maxsi then call putsbb(no);
     124                  else call ermsg(89, i);
     125                  end if;
     126
     127              else
     128                  do  j = 0 to vlen(i)-1;
     129                      call putsbi(val(vptr(i)+j));
     130                  end do;
     131              end if;
     132
     133              putbhdr(bt_tuple, 1)
     134
     135          else
     136              call putsbb(no);    $ has_value_ in setl.opt = false
     137          end if;
     138
     139          putbhdr(bt_tuple, 1)
     140      end do;
     141$
     142$ block table
     143$
     144      call putsbi(blocktab_org);   call putsbi(blocktabp);
     145
     146      do i = blocktab_org+1 to blocktabp;
     147          call putsbi(b_first(i));
     148      end do;
     149$
     150$ code table
     151$
     152      call putsbi(codetab_org);   call putsbi(codetabp);
     153
     154      do i = codetab_org+1 to codetabp;
     155          putbhdr(bt_tuple, 0)
     156
     157          call putsbi(opcode(i));
     158          call putsbi(blockof(i));
     159          call putsbi(next(i));
     160          call putsbi(cflag(i));
     161          call putsbi(sflag(i));
     162
     163          call putsbi(nargs(i));
     164
     165          putbhdr(bt_tuple, 0)
     166
     167          do j = 1 to nargs(i);
     168              call putsbi(argtab(argp(i)+j));
     169          end do;
     170
     171          putbhdr(bt_tuple, 1)
     172
     173          putbhdr(bt_tuple, 1)
     174      end do;
     175
     176 ..sq1
     177
     178
     179      end subr sputtb;
       1 .=member putsbi
       2      subr putsbi(arg);
       3
       4$ this routine writes out the argument as a setl binary integer
       5$ to the setl q1 file.
smfc  12$
smfc  13$ n.b.  the code here corresponds to the code of the putintli and putbli
smfc  14$ routines in the run-time library.  it does depend on the exact repre-
smfc  15$ sentation of setl long integers.  strictly speaking, we simulate the
smfc  16$ sequence
smfc  17$
smfc  18$       put_intval(spec, arg); putbli(sq1_file, spec);
smfc  19$
smfc  20$ without using the heap.
       6
       7
       8 .+sq1.
       9
      10      size arg(ws);           $ integer argument
      11      size putbhdrblk(ws);    $ binary header block
smfc  21      size putbdatblk(ws);    $ binary data block
      12
      13
smfd  11      if 0 <= arg & arg <= bh_val_max then
smfd  12
smfd  13          putbhdr(bt_sint, arg);
smfd  14
smfd  15      elseif iabs(arg) < li_dbas then
smfc  23
smfc  24          putbhdr(bt_int, 1)
smfc  25
smfc  26          putbdatblk = 0;
smfc  27          .f.  1, dds, putbdatblk = iabs(arg);  $ li_ddigit
smfc  28          .f. ws,   1, putbdatblk = (arg < 0);  $ li_sign
smfc  29          putbdat(putbdatblk)
smfc  30
smfc  31      else
smfc  32          putbhdr(bt_int, 2)
smfc  33
smfc  34          putbdatblk = 0;
smfc  35          .f.  1, dds, putbdatblk = iabs(arg);  $ li_ddigit
smfc  36          .f. ws,   1, putbdatblk = (arg < 0);  $ li_sign
smfc  37          putbdat(putbdatblk)
smfc  38
smfc  39          putbdatblk = 0;
smfc  40          .f.  1, dds, putbdatblk = .f. dds+1, ws-dds-1, iabs(arg);
smfc  41          putbdat(putbdatblk)
smfc  42      end if;
      16
      17 ..sq1
      18
      19
      20      end subr putsbi;
       1 .=member putsbr
       2      subr putsbr(arg);
       3
       4$ this routine writes out the argument as a setl binary real
       5$ to the setl q1 file.
       6
       7
       8 .+sq1.
       9
      10      size arg(ws);           $ real argument
      11      size putbhdrblk(ws);    $ binary header word
      12
      13
      14      putbhdr(bt_real, 1)
      15      putbdat(arg)
      16
      17
      18 ..sq1
      19
      20      end subr putsbr;
       1 .=member putsbb
       2      subr putsbb(arg);
       3
       4$ this routine writes a little flag as a setl boolean onto the
       5$ setl q1 file
       6
       7
       8 .+sq1.
       9
      10      size arg(1);            $ little boolean
      11      size putbhdrblk(ws);    $ binary header block
      12      size putbdatblk(ws);    $ binary data block
      13
      14
      15      putbdatblk = arg;       $ widen to full ws bitstring
      16
      17      putbhdr(bt_bool, 1)
      18      putbdat(putbdatblk)
      19
      20
      21 ..sq1
      22
      23      end subr putsbb;
       1 .=member putsbs
       2      subr putsbs(arg);
       3
       4$ this routine writes out the character string specified by the
       5$ argument as a setl binary string to the setl q1 file.
       6$
       7$ the argument is a symbol table pointer with the following
       8$ interpretion:
       9$
      10$ arg = 0:   write a null string
      11$
      12$ arg < 0:   write the string from val(-arg)
      13$
      14$ arg > 0:   for non-internal variables, write their name;
      15$            otherwise, write a null string.
      16
      17
      18 .+sq1.
      19
      20      size arg(ws);           $ string argument
      21
      22      size putbhdrblk(ws);    $ binary header block
      23      size str(sds_sz);       $ string
      24      size org(ps);           $ string origin
      25      size len(ps);           $ number of characters in string
      26      size words(ps);         $ number of words in the string
      27      size j(ps);             $ loop index
      28
      29      size namsds(sds_sz);    $ converts names entry to sds string
      30
      31
      32      if arg > 0 then         $ write the name of the variable
      33          if ^ is_internal(arg) then
      34              str = namsds(name(arg));
      35          else
      36              str = '';
      37          end if;
      38
      39      elseif arg < 0 then     $ write the string constant from val(-arg)
      40          words = vlen(-arg);
      41
      42          do j = 0 to words - 1;
      43              .f. 1+j*ws, ws, str = val(vptr(-arg)+j);
      44          end do;
      45
      46      else                    $ arg = 0: write a null string
      47          str = '';
      48      end if;
      49
      50      len = slen str;
      51
      52      if len then
      53          words = ((len-1) / cpw) + 1;
      54      else
      55          words = 0;
      56      end if;
      57
      58      putbhdr(bt_string, len)
      59
      60      org      = sorg str;
      61      sorg str = 0;
      62      slen str = 0;
      63
      64      do j = 1 to words;
      65          write sq1_file, (.f. org-j*ws, ws, str);
      66      end do;
      67
      68      macdrop(putbhdr)
      69      macdrop(putbdat)
      70
      71
      72 ..sq1
      73
      74      end subr putsbs;
       1 .=member binder
       2      subr binder;
       3
       4$ this unit is called at the start of compilation. it merges the
       5$ results of all previous compilations into the new q1 file.
       6
       7$ the following nameset contains globals used to bind separate
       8$ compilations:
       9
      10      nameset bind;
      11
      12$ the array 'smap' maps pointers to the symbol table contained
      13$ on 'bind_file' into pointers to the symbol table contained in
      14$ core.
      15
      16          +*  smap(i)  =
suna  51 .+r32        .f. 1 + mod(i-1, 2)*16, 16, a_smap((i-1)/2+1)
suna  52 .+r36        .f. 1 + mod(i-1, 2)*18, 18, a_smap((i-1)/2+1)
      17 .+s66        .f. 1 + mod(i-1, 4)*15, 15, a_smap((i-1)/4+1)
      23              **
      24
      25          size a_smap(ws);
      26
suna  53 .+r32    dims a_smap(symtab_lim/2);
suna  54 .+r36    dims a_smap(symtab_lim/2);
      27 .+s66    dims a_smap(symtab_lim/4);
      33
      34$ the array 'fmap' serves the same function for formtab.
      35
      36          +*  fmap(i)  =
suna  55 .+r32        .f. 1 + mod(i, 2)*16, 16, a_fmap((i)/2+1)
suna  56 .+r36        .f. 1 + mod(i, 2)*18, 18, a_fmap((i)/2+1)
      37 .+s66        .f. 1 + mod(i, 4)*15, 15, a_fmap(i/4+1)
      43              **
      44
      45          size a_fmap(ws);
      46
suna  57 .+r32    dims a_fmap(formtab_lim/2);
suna  58 .+r36    dims a_fmap(formtab_lim/2);
      47 .+s66    dims a_fmap(formtab_lim/4);
      53
      54
      55$ the binding routines also used three pointers into each array xxx:
      56
      57$ x_org:      first entry in old table being read in
      58$ x_last:     last entry in old table being read in
      59$ x_bias:     see below
      60
      61$ the high order end of each array is used as a temporary buffer
      62$ to store the slice of the array being read in from the old q1 file.
      63$ the old table entry xxx(i) is temporarily stored at xxx(i+x_bias).
      64
      65          size n_org(ps),   $ pointers for names
      66               n_last(ps),
      67               n_bias(ps);
      68
      69          size v_org(ps),   $ pointers for val
      70               v_last(ps),
      71               v_bias(ps);
      72
      73          size s_org(ps),   $ pointers for symtab
      74               s_last(ps),
      75               s_bias(ps);
      76
      77$ pointers for formtab. since formtab is zero origined, f_org
      78$ can take on a value of -1. this means that it must be sized ws.
      79          size f_org(ws),
      80               f_last(ps),
      81               f_bias(ps);
      82
      83          size m_org(ps),   $ pointers for mttab
      84               m_last(ps),
      85               m_bias(ps);
      86
      87$ codetab, argtab, and blocktab are always read in their entirety,
      88$ and do not need special pointers.
      89
      90      end nameset;
      91
      92      size ret(ws);       $ return code from namesio
      93
      94      if bind_title .sne. '' then
      95      until filestat(bind_file, end);
      96          call readpg;
      97      end until;
      98      end if;
      99
     100      if ibnd_title .sne. '' then
     101      until filestat(ibnd_file,end);
     102          bind_title = '0';
     103          get ibnd_file  :bind_title,a(filenamlen),skip;
     104          if ( ' ' .in. bind_title )
     105                 slen  bind_title = ( ' ' .in. bind_title ) - 1;
     106          file bind_file    access = read,  title = bind_title;
     107          if filestat(bind_file,access) = 0 then
     108              put, column(7), 'attempt to open file '
     109                   :bind_title, a, '.', skip(1);
     110              call ermsg(87, 0);
     111          else
     112              call namesio(bind_file,ret,bind_title,filenamlen);
     113$                             get true name of file included for message
bnda 138              if (et_flag) put ,'reading from file ' :bind_title,a,skip;
     116 .+s66        rewind bind_file;           $ force rewinding
     117              until filestat(bind_file,end);
     118                  call readpg;
     119              end until;
     120              file bind_file  access=release;
     121          end if;
     122      end until;
     123      end if;
     124
     125
     126$ reinitialize unit name and type, etc.
     127      curunit   = 0;
     128      unit_type = unit_sys;
     129
     130      curmemb   = 0;
     131      currout   = 0;
     132
     133
     134      end subr binder;
       1 .=member readpg
       2      subr readpg;
       3
       4$ this routine reads a single page of q1 from 'old_file'. this
       5$ is done in the following steps:
       6
       7$ 1. save the current values of symtabp, etc. so that we are
       8$    ready to restore them at the end of the page.
       9
      10$ 2. read the unit type and name. determine whether we have seen this
      11$    unit before.
      12
      13$ 3. read each of the q1 tables into the high order end of the
      14$    corresponding array.
      15
      16$ 4. hash the entries at the high order end of symtab into the low
      17$    order end.
      18
      19$ 5. repeat (3) for formtab.
      20
      21$ 6. adjust the new argtab entries to point to the adjusted symtab
      22$    entries.
      23
      24$ 7. adjust the new val entries for sets, tuples, etc. to point to
      25$    the new symtab entries.
      26
      27$ 8. if we have not seen this unit before, write out the new page
      28
      29$ 9. if this is the end of a procedure or member, release the space
      30$    used by local variables.
      31
      32      access bind;
      33
      34      size nprocs(ps),     $ number of procs in member
      35           nseen(ps),      $ number seen so far
      36           membtype(ps),   $ unit type of current member
      37           str(sds_sz),    $ name of unit as sds
      38           p(ps),          $ symtab pointer
      39           n(ps);          $ number of routines
      40
      41$ we read each table slice into the high order end of the
      42$ corresponding table. when we read a slice of the array xxx
      43$ we set three variables:
      44
      45$ x_org:      orign of slice in predefined q1 table
      46$ x_last:     end of slice in predefined table
      47$ x_bias:     see below
      48
      49$ xxx(i) is always read into xxx(i+x_bias).
      50
      51      +*  getr(ara, ptr, lim, org, last, bias) =
      52          size zzza(ws),    $ length of slice
      53               zzzb(ws);    $ origin of temporary buffer area
      54
      55          read bind_file, org, last;
      56
      57          zzza = last-org;
      58          zzzb = lim-zzza;
      59
      60          bias = zzzb-org;
      61          if (zzzb < ptr) call overfl('getr');
      62
      63          if (zzzb < lim) read bind_file, ara(zzzb+1) to ara(lim);
      64          **
      65
      66$ the slices for codetab, argtab, and blocktab always have org = 0.
      67$ we read them directly into the low order end of the appropriate
      68$ tables.
      69
      70      +*  getr1(ara, org, last)  =
      71          read bind_file, org, last;
      72          if (org < last) read bind_file, ara(org+1) to ara(last);
      73          **
      74
      75      push3(namesp, symtabp, valp);  $ save table pointers
      76
      77$ read header information.
      78      read bind_file, unit_type, str, p, n, ustmt_count, estmt_count;
      79
      80      if filestat(bind_file, end) ! unit_type = unit_end then
      81          free_stack(3);
      82          return;
      83
      84      elseif unit_type = unit_sys then    $ standard prelude
      85          curunit = 0;
      86          curmemb = 0;
      87
      88      else
bnda 139          if (et_flag) put ,'binding ' :str,a ,skip;
      90          curunit = hashst(str);
      91
      92          if unit_type = unit_proc then
      93              currout  = curunit;
      94          else
      95              curmemb  = curunit;
      96              membtype = unit_type;
      97              nprocs   = n;
      98              nseen    = 0;
      99          end if;
     100      end if;
     101
     102$ read the tables
     103
     104
     105      getr(mttab,    mttabp,    mttab_lim,    m_org, m_last, m_bias)
     106      getr(formtab,  formtabp,  formtab_lim,  f_org, f_last, f_bias)
     107      getr(names,    namesp,    names_lim,    n_org, n_last, n_bias)
     108      getr(val,      valp,      val_lim,      v_org, v_last, v_bias)
     109      getr(symtab,   symtabp,   symtab_lim,   s_org, s_last, s_bias)
     110
     111      getr1(blocktab, blocktab_org, blocktabp)
     112      getr1(argtab,   argtab_org,   argtabp)
     113      getr1(codetab,  codetab_org,  codetabp)
     114
     115$ hash in symtab and formtab entries
     116      call msyms;
     117      call mforms;
     118      call adjarg;
     119      call adjvls;
     120
     121      if unit_type = unit_sys then  $ reset pointers and return
     122          call reset;
     123          return;
     124
     125      else           $ write tables if not yet seen
     126
     127          if ^ is_seen(curunit) then
     128              is_seen(curunit) = yes;
     129              call gputtb;
     130          end if;
     131
     132          if unit_type = unit_proc then $ clear local variables
     133              call reset;
     134              nseen = nseen + 1;
     135
     136              if nseen = nprocs then  $ clear symbols for member
     137                  unit_type = membtype;
     138                  call reset;
     139              end if;
     140          end if;
     141      end if;
     142
     143
     144      macdrop(getr)
     145      macdrop(getr1)
     146
     147
     148      end subr readpg;
       1 .=member msyms
       2      subr msyms;
       3
       4$ hash the symtab entries we have just read from bind_file into
       5$ symtab.
       6
       7      access bind;
       8
      11      size old(ps),  $ pointer to old symtab
      12           new(ps),  $ pointer to new symtab
      13           temp(ps); $ pointer to temporary location in symtab
      14      size v_new(ps);         $ pointer to new val entry
      15      size v_temp(ps);        $ pointer to temporary val entry
      16      size v_len(ps);         $ length of val entry
bnda 140      size f_temp(ps);        $ pointer to temporary form table entry
bnda 141      size f_new(ps);         $ pointer to temporary form table entry
bnda 142      size hashc(ws);         $ hash code
bnda 143      size indx(ps);          $ index into hash table
bnda 144      size j(ps);             $ loop counter
bnda 145      size k(ps);             $ loop counter
      17
      18      size nam(ps),    $ pointer to names entry
      19           words(ps);  $ length of names entry
      20
      21      size ara(ws);    $ array for new names entry
      22      dims ara((toklen_lim-1)/cpw+1);
      23
      24      do old = s_org+1 to s_last;
      25          temp = old + s_bias;
      26          nam  = name(temp);
      27
      28          if nam = 0 then $ generated name
bnda 146              f_temp = form(temp);
bnda 147              if f_temp > f_org then  $ not yet merged.
bnda 148                  f_temp = f_temp + f_bias;  $ index unmerged table.
bnda 149              else
bnda 150                  f_temp = fmap(f_temp);  $ index merged table.
bnda 151              end if;
bnda 152              if is_ftup(f_temp) ! is_fset(f_temp) then
bnda 153                  $ hash the value in the old symbol table.
bnda 154                  $ first compute the hash code for the constant.
bnda 155                  hashc = 0;
bnda 156                  v_temp = vptr(temp) + v_bias;
bnda 157                  do j = v_temp to v_temp+vlen(temp)-1;
bnda 158                      hashc = hashc .ex. smap(val(j));
bnda 159                  end do j;
bnda 160                  hashc = (.f. 1, ws/2, hashc) .ex.
bnda 161                              (.f. ws/2+1, ws/2, hashc);
bnda 162
bnda 163                  $ then search the clash list for this hash code to see
bnda 164                  $ whether another set (or tuple) with the same value
bnda 165                  $ exists.
bnda 166
bnda 167                  indx = mod(hashc, heads_lim)+1;
bnda 168                  new  = heads(indx);
bnda 169                  while new ^= 0;
bnda 170                      until 1;  $ exit when not this symtab entry.
bnda 171                          if (name(new) ^= 0) quit until 1;
bnda 172
bnda 173                          f_new = form(new);  $ get form of 'new'.
bnda 174                          if is_local(new) then  $ form not yet mapped.
bnda 175                              if f_new > f_org then  $ index temp table.
bnda 176                                  f_new = f_new + f_bias;
bnda 177                              else    $ index merged table.
bnda 178                              f_new = fmap(f_new);
bnda 179                              end if;
bnda 180                          end if;
bnda 181                          if (is_fset(f_temp) ^= is_fset(f_new)) quit;
bnda 182                          if (is_ftup(f_temp) ^= is_ftup(f_new)) quit;
bnda 183
bnda 184                          if (vlen(new) ^= vlen(temp)) quit until 1;
bnda 185                          v_new = vptr(new);
bnda 186                          if is_local(new) then  $ val not yet mapped.
bnda 187                              do k = 0 to vlen(temp)-1;
bnda 188                                  if smap(val(v_temp+k)) ^=
bnda 189                                          smap(val(v_new+k)) then
bnda 190                                      quit until 1;
bnda 191                                  end if;
bnda 192                              end do k;
bnda 193                          else
bnda 194                              do k = 0 to vlen(temp)-1;
bnda 195                                  if (smap(val(v_temp+k)) ^=
bnda 196                                          val(v_new+k)) quit until 1;
bnda 197                              end do k;
bnda 198                          end if;
bnda 199                          $ found a matching entry:  return it.
bnda 200                          smap(old) = new;
bnda 201                          cont do old;
bnda 202
bnda 203                      end until 1;
bnda 204                      new = link(new);
bnda 205                  end while;
bnda 206
bnda 207                  new = getsym(0);  $ generate new entry.
bnda 208                  link(new) = heads(indx);  $ add to clash list.
bnda 209                  heads(indx) = new;
bnda 210
bnda 211              else
bnda 212                  new = getsym(0);
bnda 213              end if;
      30          else
      31              words = n_sorg(nam + n_bias)/ws;
      32
      33              do j = 1 to words;
      34                  ara(j) = names(nam + n_bias - 1 + j);
      35              end do;
      36
      37              new = hash(ara, words);
      38          end if;
      39
      40          smap(old) = new;
      41
      42$ see if the name has already been seen in another unit.  there are
      43$ three possibilities:
      44
      45$ 1. we are processing the current unit for the second time.
      46$    this will be true if we are processing the system unit
      47$    (which is written out in every compilation) or is
      48$    is_seen(curunit) = yes.
      49
      50$    there are two possibilities here:
      51
      52$    a. the name is a global base.  in this case there are two
      53$       formtab entries for the base: one in the old part of
      54$       the form table, and one in the new unit we are reading in.
      55$       we adjust fmap so that it sends the new form into the old one.
      56
      57$    b. otherwise we go on to the next symbol.
      58
      59$ 2. the name is itself a member.  go on to the next symbol.
      60
      61$ 3. otherwise the same name is used in two conflicting scopes,
      62$    and we issue an error message.
      63
      64          if ^ is_local(new) then
      65              if unit_type = unit_sys ! is_seen(curmemb) then
      66                  if (is_base(new)) fmap(form(temp)) = form(new);
bnda 214                  if (is_floc(form(new))) fmap(form(temp)) = form(new);
      67                  cont;
      68
      69              elseif is_memb(new) then
      70                  cont;
      71
      72              else
      73                  call ermsg(2, new);
      74                  cont;
      75              end if;
      76          end if;
      77
      78          if vptr(temp) ^= 0 & alias(temp) = 0 then
      79              v_new  = valp+1;
      80              v_temp = vptr(temp) + v_bias;
      81              v_len  = vlen(temp);
      82
      83              valp = valp + v_len;
      84              if (valp > v_org + v_bias) call overfl('val');
      85
      86              do j = 0 to v_len-1;
      87                  val(v_new + j) = val(v_temp + j);
      88              end do;
      89
      90              vptr(new) = v_new;
      91              vlen(new) = v_len;
      92          end if;
      93
      94          form(new)      =   form(temp);
      95          tprev(new)     =   tprev(temp);
      96          tlast(new)     =   tlast(temp);
      97
      98          is_mode(new)   =   is_mode(temp);
      99          is_perf(new)   =   is_perf(temp);
     100          is_decl(new)   =   is_decl(temp);
     101          is_repr(new)   =   is_repr(temp);
     102          is_temp(new)   =   is_temp(temp);
     103          is_stk(new)    =   is_stk(temp);
     104          is_read(new)   =   is_read(temp);
     105          is_write(new)  =   is_write(temp);
     106          is_param(new)  =   is_param(temp);
     107          is_store(new)  =   is_store(temp);
     108          is_init(new)   =   is_init(temp);
     109          is_avail(new)  =   is_avail(temp);
     110          $ nb. is_seen may neither be copied from the temporary entry,
     111          $ nor reset.
     112          is_back(new)   =   is_back(temp);
     113          is_rec(new)    =   is_rec(temp);
     114      end do;
     115
     116      do old = s_org+1 to s_last;
     117          temp = alias(old + s_bias);
     118          if temp ^= 0 then
     119              new = smap(old);   temp = smap(temp);
     120
     121              alias(new) = temp;
     122
bnda 215              if vptr(old + s_bias) ^= 0 then  $ copy val ptr and len.
bnda 216                  vptr(new) = vptr(temp);
bnda 217                  vlen(new) = vlen(temp);
bnda 218              end if;
     125          end if;
     126      end do;
     127
     128
     129      end subr msyms;
       1 .=member mforms
       2      subr mforms;
       3
       4$ this routine reads in the old formtab.  we read one entry at
       5$ a time and hash it in.
       6
       7      access bind;
       8
       9      size n(ps),  $ number of entries
      10           j(ps),  $ loop index
      11           tp(ps), $ type code
      12           org(ps),$ origin in mttab
      13           len(ps),$ length of mttab entry
      14           b(ps);  $ base name
      15
      16      size old(ps),    $ old formtab pointer
      17           new(ps),    $ new formtab pointer
      18           temp(ps);   $ temporary location at high end of formtab
      19
      20      do old = f_org+1 to f_last;
      21
      22          if old <= f_max then  $ standard type f_xxx
      23              fmap(old) = old;
      24              cont;
      25          end if;
      26
      27          temp = old + f_bias;
      28
      29$ suppose 'b' is a global base.  then the unit containing 'b'
      30$ may be read in more than once.  for example, the 'bind' file
      31$ may contain the results of several compilations, each of
      32$ which contains a copy of the directory which declares 'b'.
      33$ each time we read in the directory we must give 'b' the same
      34$ form.
      35
      36$ when 'msyms' read in the symbol table it checked each
      37$ base 'b' to see whether it was seeing it for the second time.
      38$ if so, if set 'fmap(new entry) = form(old entry)'.  if it did
      39$ this then we go on to the next formtab entry.
      40
      41          if (is_fbase(temp) & fmap(old) ^= 0) cont;
bnda 219          if (is_floc(temp) & fmap(old) ^= 0) cont;
      42
      43$ otherwise build a new formtab entry
      44          countup(formtabp, formtab_lim, 'formtab');
      45
      46          formtab(formtabp) = formtab(temp);
      47          ft_link(formtabp) = 0;
bnda 220          ft_deref(formtabp) = 0;
      48
      49$ handle procedures and mixed tuples specially
      50          tp = ft_type(formtabp);
      51
      52          if tp = f_mtuple ! tp = f_proc then
      53              ft_elmt(formtabp) = mttabp;
      54
      55              org = ft_elmt(temp) + m_bias;
      56              len = ft_lim(formtabp);
      57
      58              do j = 1 to len;  $ adjust pointers
      59                  countup(mttabp, mttab_lim, 'mttab');
      60                  mttab(mttabp) = fmap(mttab(org+j));
      61              end do;
      62
      63
      64              fmap(old) = hashf2(0);  $ hash in form
      65
      66          else   $ doesnt use mttab
bnda 221              ft_elmt(formtabp) = fmap(ft_elmt(formtabp));
bnda 222
bnda 223              if is_fbase(formtabp) = no then
bnda 224                  ft_dom(formtabp)   = fmap(ft_dom(formtabp));
bnda 225                  ft_im(formtabp)    = fmap(ft_im(formtabp));
bnda 226                  ft_imset(formtabp) = fmap(ft_imset(formtabp));
bnda 227                  ft_base(formtabp)  = fmap(ft_base(formtabp));
bnda 228              end if;
      72
      73              if is_frem(formtabp) then
      74                  ft_tup(formtabp) = fmap(ft_tup(formtabp));
      75              end if;
      76
bnda 229              if is_floc(formtabp) ! is_fbase(formtabp) then
bnda 230                  ft_deref(formtabp) = formtabp;
      78                  fmap(old) = formtabp;
      79              else
      80                  fmap(old) = hashf1(0);
      81              end if;
      82          end if;
      83
      84      end do;
      85
      86
      87      end subr mforms;
       1 .=member adjarg
       2      subr adjarg;
       3
       4$ adjust the pointers from argtab and blocktab to symtab
       5
       6      access bind;
       7
       8      size j(ps);   $ loop index
       9
      10      do j = 1 to argtabp;
      11          argtab(j) = smap(argtab(j));
      12      end do;
      13
      14      do j = 1 to blocktabp;
      15          b_rout(j) = smap(b_rout(j));
      16      end do;
      17
      18
      19      end subr adjarg;
       1 .=member adjvls
       2      subr adjvls;
       3
       4$ this routine iterates over symtab, reseting the form fields
       5$ to their new values then updating 'val' entries.
       6
       7
       8      access bind;
       9
      10      size old(ps),   $ old symtab pointer
      11           new(ps);   $ new symtab pointer
      12
      13      do old = s_org+1 to s_last;
      14          new = smap(old);
      15
      16          if (^ is_local(new)) cont;
      17
      18          form(new) = fmap(form(new));
bnda 231
bnda 232          if (vptr(new) = 0) cont do;  $ no val entry.
bnda 233          if (alias(new) ^= 0) cont do;  $ will be mapped with alias.
bnda 234
bnda 235          call adjval(new);  $ adjust val entry.
bnda 236
      20      end do;
      21
      22
      23      end subr adjvls;
       1 .=member adjval
       2      subr adjval(sym);
       3
       4$ this routine adjusts the value of a symtab entry. it is essentially
       5$ a big jump on the type of the entry.
       6
       7      access bind;
       8
       9      size sym(ps);  $ symbol to be adjusted
      10
      11      size ptr(ps), $ its vptr
      12           len(ps); $ its vlen
      13
      14      size j(ps),  $ loop index
      15           org(ps), $ origin in val
      16           n(ps);   $ length of entry
      17
      18      access bind;
      19
      20      ptr = vptr(sym);
      21      len = vlen(sym);
      22
      23      if (ptr = 0) return;   $ no val entry
      24
      25      go to case(symtype(sym)) in f_min to f_max;
      26
      27
      28/case(f_gen)/
      29
      30/case(f_sint)/
      31
      32/case(f_sstring)/
      33
      34/case(f_atom)/
      35
      36/case(f_latom)/
      37
      38/case(f_int)/
      39
      40/case(f_string)/
      41
      42/case(f_real)/
      43
      44/case(f_lab)/
      45
      46/case(f_ureal)/
      47
      48/case(f_uint)/
      49
      50/case(f_error)/
      51
      52      return;
      53
      54
      55/case(f_elmt)/     $ element
      56
      57      val(ptr) = smap(val(ptr));
      58
      59      return;
      60
      61
      62/case(f_tuple)/
      63
      64/case(f_ptuple)/
      65
      66/case(f_ituple)/
      67
      68/case(f_rtuple)/
      69
      70/case(f_mtuple)/
      71
      72/case(f_uset)/
      73
      74/case(f_umap)/
      75
      76/case(f_lset)/
      77
      78/case(f_rset)/
      79
      80/case(f_lmap)/
      81
      82/case(f_rmap)/
      83
      84/case(f_lpmap)/
      85
      86/case(f_limap)/
      87
      88/case(f_lrmap)/
      89
      90/case(f_rpmap)/
      91
      92/case(f_rimap)/
      93
      94/case(f_rrmap)/
      95
      96/case(f_base)/
      97
      98/case(f_pbase)/
      99
     100/case(f_uimap)/
     101
     102/case(f_urmap)/         $ sets, tuples, and bases
     103
     104      do j = 0 to len-1;
     105          val(ptr+j) = smap(val(ptr+j));
     106      end do;
     107
     108      return;
     109
     110
     111/case(f_proc)/    $ procedures and functions
     112
     113      val(ptr) = smap(val(ptr));  $ temporary for returned value
     114
     115      return;
     116
     117
     118/case(f_memb)/    $ members
     119
     120      org = ptr;     $ zero-th library
     121      n = val(org);
     122
     123      do j = 1 to n;
     124          val(org+j) = smap(val(org+j));
     125      end do;
     126
     127      org = org + n + 1;  $ zero-th reads variable
     128      n = val(org);
     129
     130      do j = 1 to n;
     131          val(org+j) = smap(val(org+j));
     132      end do;
     133
     134      org = org + n + 1;  $ zero-th writes variable
     135      n = val(org);
     136
     137      do j = 1 to n;
     138          val(org+j) = smap(val(org+j));
     139      end do;
     140
     141
     142      org = org + n + 1;  $ zero-th exports variable
     143      n = val(org);
     144
     145      do j = 1 to n;
     146          val(org+j) = smap(val(org+j));
     147      end do;
     148
     149      org = org + n + 1;  $ zero-th 'imported' variable
     150      n = val(org);
     151
     152      do j = 1 to n;
     153          val(org+j) = smap(val(org+j));
     154      end do;
     155
     156      return;
     157
     158
     159      end subr adjval;
       1 .=member reset
       2      subr reset;
       3
       4$ this routine deletes some of the table entries for the page
       5$ we have just merged into the symbol table.
       6
       7$ as usual we save the values of various table pointers at the
       8$ start of each unit. usually we call 'greset' at the end of
       9$ the unit to reset the pointers to their saved values. this
      10$ deletes all the table entries for the unit.
      11
      12$ when we read in a unit from the bind_file we must keep
      13$ certain entries in the symbol table. this is done by
      14$ branching on the type of the current unit
      15$ and taking the appropriate action. for procedures and
      16$ modules we simply call 'greset'. for libraries and
      17$ directories we take special actions.
      18
      19      size j(ps),  $ loop index
      20           p(ps);  $ symbol table pointer
      21
      22$ jump on the type of the current unit and reset symtabp, etc.
      23      go to case(unit_type) in unit_min to unit_max;
      24
      25/case(unit_sys)/   $ system unit
      26
      27$ the only new entries added to symtab when we bind a copy of
      28$ the system unit are a series of internally generated constants
      29$ which are never used. we simply restore the pointers to their
      30$ stacked values.
      31
      32      pop3(valp, symtabp, namesp);
      33
      34      names_org  = namesp;
      35      symtab_org = symtabp;
      36      val_org    = valp;
      37
      38      return;
      39
      40
      41/case(unit_lib)/  $ library
      42
      43$ reset the various pointers to the start of the library then
      44$ advance them so that we keep all exported procedures and there
      45$ return variables.
      46
      47      pop3(valp, symtabp, namesp);
      48
      49$ note that in the loop which follows symtabp points to the last
      50$ saved entry. we examine symtab(symtabp+1) to see if it should
      51$ also be saved.
      52
      53$ we use the following macro to adjust symtabp, namesp, and valp.
      54
      55      +*  keep_symbol  =
      56          size zzza(ps),   $ misc pointers
      57               zzzb(ps),
      58               zzzc(ps);
      59
      60          symtabp = symtabp + 1;      $ adjust symtabp
      61
      62$ get a pointer to the last word of the names entry and see if
      63$ it goes beyond namesp.
      64
      65          zzza = name(symtabp);       $ names pointer
      66          zzzb = n_sorg(zzza)/ws;     $ number of words in name
      67          zzzc = zzza + zzzb - 1;     $ last word in names entry
      68
      69          if (namesp < zzzc) namesp = zzzc;
      70
      71          if vptr(symtabp) ^= 0 then  $ adjust valp
      72              zzza = vptr(symtabp) + vlen(symtabp) - 1;
      73              if (valp < zzza) valp = zzza;
      74          end if;
      75          **
      76
      77      while 1;
      78          if is_proc(symtabp+1) then  $ exported proc
      79              keep_symbol;
      80
      81$ skip variable used to return procedure value
      82              keep_symbol;
      83
      84          elseif is_memb(symtabp+1) then  $ referenced library
      85              keep_symbol;
      86
      87          else
      88              quit;
      89          end if;
      90      end while;
      91
      92      names_org  = namesp;  $ reset origins
      93      symtab_org = symtabp;
      94      val_org    = valp;
      95
      96$ delete freed symtab entries from their clash lists. note that the f
      97$ freed entries are at the beginning of their clash list.
      98
      99      do j = 1 to heads_lim;
     100          p = heads(j);
     101
     102          while p > symtabp;
     103              p = link(p);
     104          end while;
     105
     106          heads(j) = p;
     107      end do;
     108
     109      call incode;   $ reinitialize code tables
     110
     111      return;
     112
     113      macdrop(keep_symbol)
     114
     115
     116
     117/case(unit_dir)/  $ program
     118
     119$ all symbols remain in symtab
     120      names_org  = namesp;
     121      symtab_org = symtabp;
     122      val_org    = valp;
     123
     124      free_stack(3);
     125      return;
     126
     127/case(unit_prog)/   $ program
     128
     129/case(unit_mod)/   $ module
     130
     131/case(unit_proc)/  $ procedure
     132
     133      call greset;
     134      return;
     135
     136/case(unit_end)/     $ end of compilation
     137
     138      return;
     139
     140
     141      macdrop(smap)
     142      macdrop(fmap)
     143
     144      end subr reset;
       1 .=member isfbsd
       2      fnct isfbsd(fm);
       3
       4$ this routine does a recursive test to check whether a form 'fm'
       5$ is based.
       6
       7      size fm(ps);   $ top level form
       8
       9      size isfbsd(1);         $ flag returned
      10
      11      size savep(ps),     $ saved astack pointer
      12           fm1(ps),       $ inner level form
      13           tp(ps),        $ ft_type
      14           j(ps);         $ loop index
      15
      16      savep = asp;
      17      push1(fm);
      18
      19      until savep = asp;
      20          pop1(fm1);
      21
      22          tp = ft_type(fm1);
      23
      24          if tp = f_elmt then
      25              isfbsd = yes;
      26              asp       = savep;
      27
      28              return;
suna  59
suna  60          elseif tp = f_gen then
suna  61              cont;
      29
      30          elseif tp = f_mtuple ! tp = f_proc then
      31              do j = 1 to ft_lim(fm1);
      32                  push1(mttab(ft_elmt(fm1)+j));
      33              end do;
      34
      35          elseif ^ is_fprim(fm1) then
      36              push1(ft_elmt(fm1));
      37          end if;
      38
      39      end until;
      40
      41      isfbsd = no;
      42
      43
      44      end fnct isfbsd;
       1 .=member ermsg
       2      subr ermsg(n, nam);
       3
       4$ this routine prints all error messages. 'n' is the error number,
       5$ and 'nam' is an optional symbol table pointer.
       6
       7$ error messages have the form:
       8$
       9$ *** error xxx at line yyy - expect zzz ***
      10$
      11$ where:
      12$
      13$ xxx is the error number
      14$ yyy is the current line number
      15$ zzz is the individual message
      16
      17$ if 'nam' is non-zero, we print the name of the symbol
      18$ table entry after the word 'expect'.
      19
      20      size n(ps),  $ message number
      21           nam(ps); $ optional symtab pointer
      22
      23      size string(sds_sz);  $ string for message
      24
      25$ we begin by jumping on the error number to assign the proper string
      26$ to 'string'. we use the following convenience macro:
      27
      28      +*  er(n, str) =
      29          /case(n)/   string = str;  go to esac;
      30          **
      31
      32
bnda 237      +*  max_case  =  99  **
      34
      35      if ( ^ ( 1 <= n & n <= max_case )) n = 0;
      36      go to case(n) in 0 to max_case;
      37
      38      er(00, 'valid error message')
      39      er(1, 'to be a constant');
      40      er(02, 'not to be a member or procedure name.');
      41      er(03, 'to specify a program variable')
      42      er(4, 'to be declared only once');
      43      er(5, 'to be declared only once');
      44      er(6, 'to be repred in proper scope');
      45      er(7, 'procedure definition to match declaration');
      46      er(8, 'to be declared only once');
      47      er(9, 'to be repered only once');
      48      er(10, 'to be a mode')
      49      er(11, 'to be a base')
      50      er(12, 'to be followed by a valid type');
      51      er(13, 'valid range set type');
bnda 238      er(14, 'to be a non-negative integer constant')
      53      er(15, 'formal parameters to be repred with procedure')
smfb 610      er(16, 'non-zero divisor')
smfb 611      er(17, 'to be an integer constant')
      56      er(18, 'legal left hand side');
      57      er(19, 'to be a valid left-hand side.');
      58      er(20, 'to be a constant set or tuple');
      59      er(21, 'to be a label');
      60      er(22, 'to be repred consitently with its value');
      61      er(23, 'to be defined only once');
      62      er(24, 'yield statement in expression block only');
      63      er(25, 'to name a procedure or perform block')
      64      er(26, 'to be defined')
      65      er(27, 'to be a defined statement label')
smfb 612      er(28, 'case tag values to be unique')
      67      er(29, 'to be a variable, not a member or procedure name.');
      68      er(30, 'to be a numeric constant following unary minus')
      69      er(31, 'no long integer denotations');
      70      er(32, 'valid real constant');
      71      er(33, 'to be defined only once');
      72      er(34, 'to be a integer character code following -char-')
      73      er(35, 'to be called');
      74      er(36, '-exit- to occur in perform block only');
      75      er(37, 'module or program header to match header in directory');
      76      er(38, 'only one header per module');
      77      er(39, 'to be declared in proper scope');
      78      er(40, 'procedure definition to match repr');
      79      er(41, 'to appear only once in parameter list');
      80      er(42, 'valid environment for -continue- or -quit-')
      81      er(43, 'to be a procedure');
      82      er(44, 'to be read-only');
      83      er(45, 'to be a valid member');
      84      er(46, 'all members in batch compilation to have same directory');
      85      er(47, 'valid debugging option');
      86      er(48, 'to be initialized in its own scope');
      87      er(49, 'to be initialized only once');
      88      er(50, 'constant expression in -init- statement');
      89      er(51, 'to have matching repr');
      90      er(52, 'to be stacked - conflict with repr');
      91      er(53, 'to be read-write');
      92      er(54, 'to occur in only one scope');
      93      er(55, 'valid type for base');
      94      er(56, 'formal parameter on formal base');
      95      er(57, 'to appear in -procs- or -exports- list');
      96      er(58, 'to appear in -uses- list');
      97      er(59, 'only typed objects in mixed tuple');
      98      er(60, '-procs- statement to appear outside procedure');
      99      er(61, 'to be declared before it is repred');
     100      er(62, 'procedure call to have proper number of arguments');
     101      er(63, 'valid options for library');
     102      er(64, 'to be declared consistently');
     103      er(65, 'to be a constant set');
     104      er(66, ' - directory name in program statement');
     105      er(67, 'to be repred with proper number of arguments');
     106      er(68, 'to have two parameters or less');
     107      er(69, '-local set(_ b)- to appear in same scope as -base b-');
     108      er(70, 'only local objects on plex bases');
     109      er(71, 'valid element type for base');
     110      er(72, 'valid element type for set or tuple');
     111      er(73, 'valid domain type for map');
     112      er(74, 'valid image type for map');
     113      er(75, 'valid component type for tuple');
     114      er(76, 'to be a variable, not a constant or parameter');
     115      er(77, 'to be imported from another member');
     116      er(78, 'to be precompiled - fatal error');
     117      er(79, 'to be a declared global constant or variable.')
     118      er(80, 'to be a declared global variable.')
     119      er(81, 'to receive non-procedure repr')
     120      er(82, 'valid constant. (omega not allowed in set)')
     121      er(83, 'to be a constant tuple or om')
     122      er(84, 'to have a tuple mode.')
     123      er(85, 'valid packed mode: cannot pack -integer 0..n-')
     124      er(86, 'to be a valid real denotation');
     125      er(87, 'to be able to open bind file');
     126      er(88, 'to be initilised by an init stmt because of plex repr')
     127      er(89, 'to be a valid constant - compiler error')
     128      er(90, 'to appear as the program member in the directory')
     129      er(91, 'to appear as a module member in the directory')
     130      er(92, 'to name a directory (symbol has been used before)')
     131      er(93, 'to name a simple program (symbol has been used before)')
     132      er(94, 'to name a library (symbol has been used before)')
     133      er(95, 'to name a procedure (symbol has been used before)')
     134      er(96, 'to be declared in a -reads- list')
     135      er(97, 'to specify a program variable')
smfb 613      er(98, 'legal language construct:  -libraries all;- is not legal')
bnda 239      er(99, 'valid integer subrange (0 <= lo <= hi)')
     136
     137/esac/   $ print error message
     138
     139      put, skip;
     140
     141      call contlpr(27, yes);  $ start to echo to terminal
     142 .+s10    put, '?';           $ emit standard s10 error marker
     143 .+s20    put, '?';           $ emit standard s10 error marker
     144      put ,'*** error ' :n ,i;
     145      if (curmemb ^= 0) put ,' at ' :symsds(curmemb) ,a;
     146      if (currout ^= 0) put ,'.'    :symsds(currout) ,a;
     147      if (curmemb ^= 0) put ,'.'    :stmt_count      ,i;
     148      put ,': expect ';
     149      if (nam ^= 0) put: symsds(nam), a, x(1);
     150
     151      if (.len. string = 0) put ,' (missing error text) ';
     152      put: string, a, ' ***', skip;
     153
     154      call contlpr(27, no);   $ stop to echo to the terminal
     155
     156      if unit_type = unit_proc then
     157          call emit(q1_error, 0, 0, 0);  $ emit error quadruple
     158      end if;
     159
     160      error_count = error_count + 1;
     161
     162      if error_count > sel then
     163          put, skip, '*** semantic error limit exceeded ***', skip;
     164          call semtrm;
     165
     166      elseif 'fatal error' .in. string then
     167          call semtrm;
     168      end if;
     169
     170      macdrop(max_case)
     171
     172
     173      end subr ermsg;
       1 .=member warn
       2      subr warn(n, nam);
       3
       4$ this routine is similar to ermsg, except that it prints
       5$ warnings.
       6
       7$ warnings have the form:
       8
       9$ *** warning xxx at line yyy - zzz ***
      10
      11$ where:
      12
      13$ xxx is the warning number
      14$ yyy is the current line number
      15$ nam is a symbol table pointer
      16$ zzz is the individual message
      17
      18$ if 'nam' is non-zero, we print the name of the symbol
      19$ table entry after the word 'expect'.
      20
      21      size n(ps),  $ message number
      22           nam(ps); $ optional symtab pointer
      23
      24      size string(sds_sz);  $ string for message
      25
      26$ we begin by jumping on the error number to assign the proper string
      27$ to 'string'. we use the following convenience macro:
      28
      29      +*  wa(n, str) =
      30          /case(n)/   string = str;  go to esac;
      31          **
      32
      33
smfb 614      +*  max_case  =  07  **
      35
      36      if ( ^ ( 1 <= n & n <= max_case )) n = 0;
      37      go to case(n) in 0 to max_case;
      38
      39      wa(0, 'expect valid warning message')
      40      wa(1, 'has illegal repr if current routine is recursive');
      41      wa(2, 'has illegal repr if backtracking is used');
      42      wa(3, 'has not yet been compiled');
      43      wa(4, 'has not been declared in a -var- statement');
      44      wa(5, 'has not been declared in a -repr- statement')
bnda 240      wa(6, 'omega illegal in tuple former (temp. compiler extension)')
smfb 615      wa(7, 'no case tag value matches the type of the case expression')
      46
      47/esac/   $ print warning
      48
      49      put, skip;
      50
      51      call contlpr(27, yes);  $ start to echo to the terminal
      52 .+s10    put, ':';           $ emit standard s10 warning character
      53 .+s20    put, ':';           $ emit standard s10 warning character
      54      put ,'*** warning ' :n ,i;
      55      if (curmemb ^= 0) put ,' at ' :symsds(curmemb) ,a;
      56      if (currout ^= 0) put ,'.'    :symsds(currout) ,a;
      57      if (curmemb ^= 0) put ,'.'    :stmt_count      ,i;
      58      put ,': ';
      59      if (nam ^= 0) put: symsds(nam), a, x;
      60
      61      put: string, a, ' ***', skip;
      62
      63      call contlpr(27, no);   $ stop to echo to the terminal
      64
      65      macdrop(max_case)
      66
      67
      68      end subr warn;
       1 .=member sdump
       2      subr sdump;
       3
       4$ this routine dumps symtab and various related tables.
       5
       6
       7      call symdmp;   $ dump symtab
       8      call valdmp;   $ dump val
       9      call fmdump;  $ dump formtab
      10      call mtdump;  $ dump mttab
      11
      12
      13      end subr sdump;
       1 .=member symdmp
       2      subr symdmp;
       3
       4$ this routine dumps symtab. the dump is formatted in columns,
       5$ with a series of column headings printed at standard intervals.
       6
bnda 241      size lines(ps);         $ number of lines since last heading
bnda 242      size str(sds_sz);       $ symbol name as sds
bnda 243      size j(ps);             $ loop counter
      10
      11
bnda 244      put ,skip(4)
bnda 245          ,'s y m t a b    d u m p   -   ' :symsds(curunit),a ,skip(2);
      14
      15      lines = lines_max;   $ set to force new heading
      16
      17      do j = 1 to symtabp;
      18          lines = lines + 1;
      19
      20          if lines > lines_max then  $ print heading
bnda 246              put ,skip(2)
bnda 247                      ,'index  name         vptr   vlen  link  alias '
bnda 248                      ,'form  tprev tlast bs md pr pf dc rp tm sk rd '
bnda 249                      ,'wr pm st in se av '
bnda 250                  ,skip
bnda 251                      ,'---------------------------------------------'
bnda 252                      ,'---------------------------------------------'
bnda 253                      ,'------------------'
bnda 254                  ,skip(2);
      30
      31              lines = 1;
      32          end if;
      33
      34          str = symsds(j);
      35          if (.len. str > 10) .len. str = 10;
      36
bnda 255          put ,column(001) :j,i
bnda 256              ,column(008) :str,a
bnda 257              ,column(021) :vptr(j),i
bnda 258              ,column(028) :vlen(j),i
bnda 259              ,column(034) :link(j),i
bnda 260              ,column(040) :alias(j),i
bnda 261              ,column(046) :form(j),i
bnda 262              ,column(052) :tprev(j),i
bnda 263              ,column(058) :tlast(j),i
bnda 264              ,column(064) :is_base(j),i
bnda 265              ,column(067) :is_mode(j),i
bnda 266              ,column(070) :is_proc(j),i
bnda 267              ,column(073) :is_perf(j),i
bnda 268              ,column(076) :is_decl(j),i
bnda 269              ,column(079) :is_repr(j),i
bnda 270              ,column(082) :is_temp(j),i
bnda 271              ,column(085) :is_stk(j),i
bnda 272              ,column(088) :is_read(j),i
bnda 273              ,column(091) :is_write(j),i
bnda 274              ,column(094) :is_param(j),i
bnda 275              ,column(097) :is_store(j),i
bnda 276              ,column(100) :is_init(j),i
bnda 277              ,column(103) :is_seen(j),i
bnda 278              ,column(106) :is_avail(j),i
bnda 279              ,skip;
      62      end do;
      63
      64
      65      end subr symdmp;
       1 .=member valdmp
       2      subr valdmp;
       3
       4$ this routine dumps val in byte format, two entries per line.
       5
bnda 280      size rows(ps);          $ number of rows in dump
bnda 281      size tab(ps);           $ current tab position
bnda 282      size i(ps);             $ index over rows
bnda 283      size j(ps);             $ index over columns
bnda 284      size indx(ps);          $ index over val
      12
bnda 285      put ,skip(4)
bnda 286          ,'v a l    d u m p   -   ' :symsds(curunit),a ,skip(2);
      15
      16      rows = (valp-1)/2 + 1;  $ number of rows
      17
      18      do i = 1 to rows;
      19          do j = 1 to 2;
      20              indx = (j-1) * rows + i;
bnda 287              tab = 1 + (j-1) * 35;
      22
bnda 288              put ,column(tab) :indx,i ,'.' ,column(tab+7) :val(indx),i;
      25          end do;
      26
bnda 289          put ,skip;
      28      end do;
      29
      30
      31      end subr valdmp;
       1 .=member fmdump
       2      subr fmdump;
       3$
       4$ this routine dumps the form table.
       5$
       6      size fm(ps);            $ loop index
       7      size lines(ps);         $ number of lines since last heading
       8      size mc(.sds. 5);       $ map code name
       9      size j1(ps), j2(ps);    $ loop indices
      10
      11      +*  lines_max  =  20  **  $ number of lines between headings
      12
      13      +*  ftname(tp)  =  a_ftname(tp+1)  **  $ array of form type names
      14
      15      size a_ftname(.sds. 7);
      16      dims a_ftname(f_max+1);
      17
      18      data ftname(f_gen)      =  'gen':
      19           ftname(f_sint)     =  'sint':
      20           ftname(f_sstring)  =  'sstring':
      21           ftname(f_atom)     =  'atom':
      22           ftname(f_latom)    =  'latom':
      23           ftname(f_elmt)     =  'elmt':
      24           ftname(f_int)      =  'int':
      25           ftname(f_string)   =  'string':
      26           ftname(f_real)     =  'real':
      27           ftname(f_uint)     =  'uint':
      28           ftname(f_ureal)    =  'ureal':
      29           ftname(f_ituple)   =  'ituple':
      30           ftname(f_rtuple)   =  'rtuple':
      31           ftname(f_mtuple)   =  'mtuple':
      32           ftname(f_ptuple)   =  'ptuple':
      33           ftname(f_tuple)    =  'tuple':
      34           ftname(f_uset)     =  'uset':
      35           ftname(f_lset)     =  'lset':
      36           ftname(f_rset)     =  'rset':
      37           ftname(f_umap)     =  'umap':
      38           ftname(f_lmap)     =  'lmap':
      39           ftname(f_rmap)     =  'rmap':
      40           ftname(f_lpmap)    =  'lpmap':
      41           ftname(f_limap)    =  'limap':
      42           ftname(f_lrmap)    =  'lrmap':
      43           ftname(f_rpmap)    =  'rpmap':
      44           ftname(f_rimap)    =  'rimap':
      45           ftname(f_rrmap)    =  'rrmap':
      46           ftname(f_base)     =  'base':
      47           ftname(f_pbase)    =  'pbase':
      48           ftname(f_uimap)    =  'uimap':
      49           ftname(f_urmap)    =  'urmap':
      50           ftname(f_error)    =  'error':
      51           ftname(f_proc)     =  'proc':
      52           ftname(f_memb)     =  'memb':
      53           ftname(f_lab)      =  'lab';
      54
      55      size mname(.sds. 4);    $ array of ft_mapc names
      56      dims mname(ft_max);
      57
      58      data mname(ft_map)      =  'map':
      59           mname(ft_smap)     =  'smap':
      60           mname(ft_mmap)     =  'mmap';
      61
      62
      63      put ,skip(4)
      64          ,'f o r m t a b    d u m p   -   '
      65          :symsds(curunit) ,a
      66          ,skip(2);
      67
      68
      69      lines = lines_max;      $ set to force new heading
      70
      71      do fm = 0 to formtabp;
      72
      73          lines = lines + 1;
      74
      75          if lines > lines_max then  $ print heading
      76              put ,skip(2)
      77                      ,'index type    mapc elmt  dom   im    imset '
      78                      ,'base  deref low   lim   hsh nlt link'
      79                  ,skip
      80                      ,'-------------------------------------------'
      81                      ,'-------------------------------------'
      82                  ,skip;
      83
      84              lines = 1;
      85          end if;
      86
      87          put ,column(01) :fm                  ,i
      88              ,column(07) :ftname(ft_type(fm)) ,a;
      89
      90          if (is_fmap(fm)) put ,column(15) :mname(ft_mapc(fm)) ,a;
      91
      92          put ,column(20) :ft_elmt(fm)  ,i
      93              ,column(26) :ft_dom(fm)   ,i
      94              ,column(32) :ft_im(fm)    ,i
      95              ,column(38) :ft_imset(fm) ,i
      96              ,column(44) :ft_base(fm)  ,i
      97              ,column(50) :ft_deref(fm) ,i;
      98
      99          put ,column(56);
     100          if (ft_type(fm) = f_sint)        put :ft_low(fm)    ,i;
     101          if (is_floc(fm) ! is_fbase(fm))  put :ft_bit(fm)    ,i;
     102
     103          put ,column(62);
     104          if (ft_type(fm) = f_sint)        put :ft_lim(fm)    ,i;
     105          if (ft_type(fm) = f_proc)        put :ft_lim(fm)    ,i;
     106          if (is_ftup(fm) ! is_fbase(fm))  put :ft_lim(fm)    ,i;
     107          if (is_floc(fm))                 put :ft_pos(fm)    ,i;
     108          if (is_frem(fm) & is_fmap(fm))   put :ft_tup(fm)    ,i;
     109
     110          put ,column(68);
     111          if (is_ftup(fm) ! is_fset(fm))   put :ft_hashok(fm) ,i;
     112
     113          put ,column(72);
     114          if (is_ftup(fm) ! is_fset(fm))   put :ft_neltok(fm) ,i;
     115
     116          put ,column(76) :ft_link(fm)  ,i;
     117
     118          if is_fbase(fm) then
     119              put ,column(86);
     120              do j1 = f_lset to f_lpmap; if ( ^ is_floc(j1)) cont do j1;
     121                  put :ft_num(fm, j1) ,i(5);
     122              end do;
     123          end if;
     124
     125          put ,skip;
     126      end do;
     127
     128
     129      end subr fmdump;
       1 .=member mtdump
       2      subr mtdump;
       3
       4$ this routine dumps mttab. we dump mttab as a series of integers,
       5$ two abreast.
       6
       7
       8      size lines(ps);         $ number of lines since last heading
       9      size j1(ps), j2(ps);    $ loop indices
      10
      11      put, skip(4), column(7), 'm t t a b    d u m p   -   ':
      12           symsds(curunit), a, skip(2);
      13
      14      lines = lines_max;      $ set to force new heading
      15
      16      do j1 = 0 to (mttabp+9)/10;
      17          lines = lines + 1;
      18          if lines > lines_max then
      19              put ,skip(2)
      20                      ,'index      ...0   ...1   ...2   ...3   ...4'
      21                      ,'   ...5   ...6   ...7   ...8   ...9'
      22                  ,skip
      23                      ,'-------------------------------------------'
      24                      ,'-----------------------------------'
      25                  ,skip;
      26               lines = 1;
      27          end if;
      28
      29          put :j1 ,i(5) ,'.   ';
      30
      31          do j2 = 0 to 9; if (j1*10+j2 > mttabp) quit do j1;
      32              if j1*10+j2 = 0 then put ,x(7); cont do j2; end if;
      33              put :mttab(j1*10+j2) ,i(6) ,x;
      34          end do;
      35
      36          put ,skip;
      37
      38      end do;
      39
      40      put ,skip(2);
      41
      42
      43      end subr mtdump;
       1 .=member q1dump
       2      subr q1dump;
       3
       4$ this routine dumps the q1 code. it essentially iterates over
       5$ blocktab, dumping a block at a time. we call 'dblock' to
       6$ dump the code for each block.
       7
       8      size j(ps),   $ loop index
       9           str(sds_sz);   $ routine name as sds
      10
      11      put, skip(4), column(7), 'c o d e    d u m p   -   ':
      12           symsds(curunit), a, skip(2);
      13
      14      do j = 1 to blocktabp;
      15          str = symsds(b_rout(j));
      16
      17          put, skip(2),  $ print heading
      18               column(07), 'block: ':   j,   i,
      19               column(20), 'routine: ': str, a,
      20               column(40), 'first: ':   b_first(j), i;
      21
      22          call dblock(b_first(j));  $ print instructions
      23      end do;
      24
      25
      26      end subr q1dump;
       1 .=member prgdmp
       2      subr prgdmp;
       3
       4$ this routine dumps the q1 code from prog_start to prog_end.
       5
       6      put, skip(4), column(7), 'p r o g r a m    d u m p    -    ':
       7           symsds(curunit), a, skip(2);
       8
       9      put, column(07), 'prog start: ': prog_start, i,
      10           column(30), 'prog end: ':   prog_end,   i,
      11           column(07), 'prog_start: ': prog_start, i,
      12           column(30), 'prog_end: ':   prog_end,   i,
      13           skip;
      14
      15      call dblock(prog_start);
      16
      17
      18      end subr prgdmp;
       1 .=member dblock
       2      subr dblock(first);
       3
       4$ this routine dumps a list of instructions starting with 'first'.
       5$ it iterates along the list until it finds a codetab pointer of 0.
       6$ the dump is formatted in columns with headings at standard
       7$ intervals.
       8
       9      size first(ps);  $ pointer to start of list
      10
      11      size p(ps),  $ current instruction
      12           op(ps),   $ current opcode
      13           j(ps),  $ loop index
      14           tab(ps),  $ tab position
      15           lines(ps),  $ lines since last header
      16           stats(ps),   $ statement counter
      17           str(sds_sz);  $ symbol as sds
      18
      19      size opname(.sds. 7);   $ names of q1 operators
      20      dims opname(q1_maximum);
      21
      22      data opname(q1_add)         =  'add':
      23           opname(q1_div)         =  'div':
      24           opname(q1_slash)       =  'slash':
      25           opname(q1_exp)         =  'exp':
      26           opname(q1_eq)          =  'eq':
      27           opname(q1_ge)          =  'ge':
      28           opname(q1_lt)          =  'lt':
smfb 616           opname(q1_pos)         =  'pos':
      29           opname(q1_in)          =  'in':
      30           opname(q1_incs)        =  'incs':
      31           opname(q1_with)        =  'with':
      32           opname(q1_less)        =  'less':
      33           opname(q1_lessf)       =  'lessf':
      34           opname(q1_max)         =  'max':
      35           opname(q1_min)         =  'min':
      36           opname(q1_mod)         =  'mod':
      37           opname(q1_mult)        =  'mult':
      38           opname(q1_ne)          =  'ne':
      39           opname(q1_notin)       =  'notin':
      40           opname(q1_npow)        =  'npow':
      41           opname(q1_atan2)       =  'atan2':
      42           opname(q1_sub)         =  'sub':
      43           opname(q1_abs)         =  'abs':
      44           opname(q1_char)        =  'char':
      45           opname(q1_ceil)        =  'ceil':
      46           opname(q1_floor)       =  'floor':
      47           opname(q1_isint)       =  'is_int':
      48           opname(q1_isreal)      =  'is_real':
      49           opname(q1_isstr)       =  'is_str':
      50           opname(q1_isbool)      =  'is_bool':
      51           opname(q1_isatom)      =  'is_atom':
      52           opname(q1_istup)       =  'is_tup':
      53           opname(q1_isset)       =  'is_set':
      54           opname(q1_ismap)       =  'is_map':
      55           opname(q1_arb)         =  'arb':
      56           opname(q1_val)         =  'val':
      57           opname(q1_dom)         =  'dom':
      58           opname(q1_fix)         =  'fix':
      59           opname(q1_float)       =  'float':
      60           opname(q1_sin)         =  'sin':
      61           opname(q1_cos)         =  'cos':
      62           opname(q1_tan)         =  'tan':
      63           opname(q1_arcsin)      =  'arcsin':
      64           opname(q1_arccos)      =  'arccos':
      65           opname(q1_arctan)      =  'arctan':
      66           opname(q1_tanh)        =  'tanh':
      67           opname(q1_expf)        =  'expf':
      68           opname(q1_log)         =  'log':
      69           opname(q1_sqrt)        =  'sqrt':
      70           opname(q1_nelt)        =  'nelt':
      71           opname(q1_not)         =  'not':
      72           opname(q1_pow)         =  'pow':
      73           opname(q1_rand)        =  'rand':
      74           opname(q1_range)       =  'range':
      75           opname(q1_type)        =  'type':
      76           opname(q1_umin)        =  'umin':
      77           opname(q1_even)        =  'even':
      78           opname(q1_odd)         =  'odd':
      79           opname(q1_str)         =  'str':
      80           opname(q1_sign)        =  'sign':
      81           opname(q1_end)         =  'end':
      82           opname(q1_subst)       =  'subst':
      83           opname(q1_newat)       =  'newat':
      84           opname(q1_time)        =  'time':
      85           opname(q1_date)        =  'date':
      86           opname(q1_na)          =  'na':
      87           opname(q1_set)         =  'set':
      88           opname(q1_set1)        =  'set1':
      89           opname(q1_tup)         =  'tup':
      90           opname(q1_tup1)        =  'tup1':
      91           opname(q1_from)        =  'from':
      92           opname(q1_fromb)       =  'fromb':
      93           opname(q1_frome)       =  'frome':
      94           opname(q1_next)        =  'next':
      95           opname(q1_nextd)       =  'nextd':
      96           opname(q1_inext)       =  'inext':
      97           opname(q1_inextd)      =  'inextd':
      98           opname(q1_of)          =  'of':
      99           opname(q1_ofa)         =  'ofa':
     100           opname(q1_argin)       =  'argin':
     101           opname(q1_argout)      =  'argout':
     102           opname(q1_asn)         =  'asn':
     103           opname(q1_push)        =  'push':
     104           opname(q1_free)        =  'free':
     105           opname(q1_sof)         =  'sof':
     106           opname(q1_sofa)        =  'sofa':
     107           opname(q1_send)        =  'send':
     108           opname(q1_ssubst)      =  'ssubst':
     109           opname(q1_call)        =  'call':
     110           opname(q1_goto)        =  'goto':
     111           opname(q1_if)          =  'if':
     112           opname(q1_ifnot)       =  'ifnot':
smfb 617           opname(q1_bif)         =  'bif':
smfb 618           opname(q1_bifnot)      =  'bifnot':
smfb 619           opname(q1_ifasrt)      =  'ifasrt':
     113           opname(q1_case)        =  'case':
     114           opname(q1_stop)        =  'stop':
     115           opname(q1_entry)       =  'entry':
     116           opname(q1_exit)        =  'exit':
     117           opname(q1_ok)          =  'ok':
     118           opname(q1_lev)         =  'lev':
     119           opname(q1_fail)        =  'fail':
     120           opname(q1_succeed)     =  'succeed':
     121           opname(q1_asrt)        =  'asrt':
     122           opname(q1_stmt)        =  'stmt':
     123           opname(q1_label)       =  'label':
     124           opname(q1_tag)        =  'tag':
     125           opname(q1_debug)       =  'debug':
     126           opname(q1_trace)        =  'trace':
     127           opname(q1_notrace)      =  'notrace':
     128           opname(q1_error)        =  'error':
     129           opname(q1_noop)        =  'noop';
     130
     131
     132
     133      p = first;
     134      lines = lines_max;
     135
     136      while p ^= 0;
     137          lines = lines + 1;
     138
     139          if lines > lines_max then
     140              lines = 1;
     141
     142              put, skip(2), column(7),
     143                   'index   opcode              args',
     144                   skip, column(7),
     145                   '-----   ------              ----',
     146                   skip;
     147          end if;
     148
     149          op = opcode(p);
     150
     151          put, column(07):          p, i,
     152               column(15): opname(op), a;
     153
     154          tab = 15;
     155
     156          do j = 1 to nargs(p);  $ print arguments
     157              tab = tab + 15;
     158
     159              if tab > 60 then
     160                  put, skip;
     161                  tab = 30;
     162              end if;
     163
     164              if op = q1_stmt then
     165                  put, column(tab): argn(p, j), i;
     166
     167              else
     168                  str = symsds(argn(p, j));
     169                  if (.len. str > 10) .len. str = 10;
     170
     171                  put, column(tab): str, a;
     172              end if;
     173
     174          end do;
     175
     176          put, skip;
     177          p = next(p);
     178      end while;
     179
     180
     181      end subr dblock;
       1 .=member csdump
       2      subr csdump;
       3
       4$ this routine dumps cstack. the dump has a format similar to the
       5$ symtab dump.
       6
       7      size j(ps),   $ loop index
       8           lines(ps),  $ number of lines since last heading
       9           tp(.sds. 5);  $ type of entry
      10
      11      size tname(.sds. 5);  $ array of cs_type names
      12      dims tname(cs_max);
      13
      14      data tname(cs_if)      =  'if':
      15           tname(cs_case)    =  'case':
      16           tname(cs_iter)    =  'iter':
      17           tname(cs_citer)   =  'citer':
      18           tname(cs_eblk)    =  'eblk';
      19
      20
      21      put, skip, column(7), 'c s t a c k    d u m p', skip;
      22      lines = lines_max;
      23
      24      do j = 1 to csp;
      25          lines = lines + 1;
      26
      27          if lines > lines_max then
      28              lines = 1;
      29
      30              put, skip(2), column(7),
      31                   'index  type  int   ldo    lstep  lterm  bvar   ',
      32                   'init/ doing/ while/ where/ body  step/  until/',
      33                   '  term',
      34                   skip, column(7),
      35                   '                                               ',
      36                   'else  end    temp   jump         num    tag  ',
      37                   skip, column(7),
      38                   '-----------------------------------------------',
      39                   '------',
      40                   '---------------------------------------------',
      41                   skip;
      42          end if;
      43
      44          tp = tname(cs_type(j));
      45
      46          put, column(007): j,              i,
      47               column(015): cs_type(j),     i,
      48               column(021): cs_internal(j), i,
      49               column(027): cs_ldoing(j),   i,
      50               column(033): cs_lstep(j),    i,
      51               column(042): cs_lterm(j),    i,
      52               column(048): cs_bvar(j),     i,
      53               column(054): cs_init(j),     i,
      54               column(060): cs_doing(j),    i,
      55               column(066): cs_while(j),    i,
      56               column(074): cs_where(j),    i,
      57               column(081): cs_body(j),     i,
      58               column(087): cs_step(j),     i,
      59               column(093): cs_until(j),    i,
      60               column(100): cs_term(j),     i,
      61               skip;
      62      end do;
      63
      64
      65      end subr csdump;
       1 .=member overfl
       2      subr overfl(msg);
       3
       4$ this routine is called when a compiler array overflows. we issue
       5$ an error message and abort.
       6
       7
       8      size msg(.sds. 50);  $ message string
       9
      10
      11      put ,skip;              $ emit blank line
      12
      13      call contlpr(27, yes);  $ start to echo to terminal
      14
      15      put, '*** compiler table overflow  -  ': msg, a;
      16
      17      if (curmemb ^= 0) put ,' at ' :symsds(curmemb) ,a;
      18      if (currout ^= 0) put ,'.'    :symsds(currout) ,a;
      19      if (curmemb ^= 0) put ,'.'    :stmt_count      ,i;
      20
      21      put, ' ***', skip;
      22
      23      call contlpr(27, no);   $ stop to echo to terminal
      24
      25      put, skip;
      26
      27      if et_flag then
      28          call sdump;
      29          call q1dump;
      30          call csdump;
      31      end if;
      32
      33      call ltlfin(1, 0);
      34
      35
      36      end subr overfl;
       1 .=member semtrm
       2      subr semtrm;
       3
       4$ this routine is called for normal termination of the semantic pass
       5
       6
       7      size j(ps);   $ loop index
       8
       9
      10$ issue warnings for all missing members.
      11
      12      do j = 1 to symtabp;
      13          if (is_memb(j) & ^ is_seen(j)) call warn(3, j);
      14      end do;
      15
      16$ write 'end of compilation' marker onto q1 file.
      17
      18      if (.len. sq1_title) then $ write setl q1 trailer
      19          call putsbi(unit_end);
      20          call putsbs(0);     $ null string
      21          call putsbi(0);
      22          call putsbi(0);
      23          call putsbi(0);
      24          call putsbi(0);
      25
      26      else
      27          write q1_file, unit_end, '' .pad. toklen_lim, 0, 0, 0, 0;
      28      end if;
      29
sunb  39      if lcs_flag then  $ print statistics
sunb  40          put ,skip;  $ emit blank line
      31
sunb  41          if error_count = 0 then
sunb  42              put, 'no errors were detected.', skip;
sunb  43          else
sunb  44              put, 'number of errors detected = ': error_count, i, skip;
sunb  45          end if;
      37
      38      +* put_stat(nam, used, lim)  =
      39          nam, '(': used, i, ',': lim, i, ')'
      40          **
      41
      42      put ,skip ,'q1 statistics:'
      43          ,skip ,put_stat('symtab',   symtab_max,   symtab_lim  ), ', '
      44                ,put_stat('val',      val_max,      val_lim     ), ', '
      45                ,put_stat('names',    names_max,    names_lim   ), '. '
      46          ,skip ,put_stat('formtab',  formtab_max,  formtab_lim ), ', '
      47                ,put_stat('mttab',    mttab_max,    mttab_lim   ), '. '
      48          ,skip ,put_stat('codetab',  codetab_max,  codetab_lim ), ', '
      49                ,put_stat('argtab',   argtab_max,   argtab_lim  ), ', '
      50                ,put_stat('blocktab', blocktab_max, blocktab_lim), '. '
      51          ,skip;
      52
      53      put ,skip ,'normal termination.' ,skip;
sunb  46
sunb  47      end if;
      54
      55      file mpol_file access = release;   $ close scratch files
      56      file xpol_file access = release;
      57      file q1_file   access = release;
      58      file sq1_file  access = release;
      59      file bind_file access = release;
      60      file ibnd_file access=release;
      61
      62      call ltlterm(2, 0);  $ call overlay exec
      63
      64
      65      end subr semtrm;
       1 .=member usratp
       2      subr usratp;
       3
       4$ this routine is called by the system in case of an abort. it
       5$ dumps various tables.
       6
       7      put ,skip(2) ,'*** fatal error detected by system '
       8                   ,'at line ' :stmt_count ,i ,' ***'
       9          ,skip(2);
      10
      11      if ( ^ et_flag) return; $ trace not requested
      12
      13      call sdump;  $ dump symtab
      14      call csdump; $ dump cstack
      15      call q1dump; $ dump q1
      16      call prgdmp;  $ dump code from prog_start to prog_end
      17
      18      stack_trace('full astack dump', asp);
      19
      20
      21      end subr usratp;

« August 2022 »
Su Mo Tu We Th Fr Sa
1 2 3 4 5 6
7 8 9 10 11 12 13
14 15 16 17 18 19 20
21 22 23 24 25 26 27
28 29 30 31
 

Powered by Plone CMS, the Open Source Content Management System

This site conforms to the following standards: