Personal tools
You are here: Home Projects SETL SETL Source code COD: Code generator; final pass of the SETL compiler.
Document Actions

COD: Code generator; final pass of the SETL compiler.

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

COD: Code generator; final pass of the SETL compiler. stlcod.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$                 cccccccc    oooooooo   ddddddddd
      15$                cccccccccc  oooooooooo  dddddddddd
      16$                cc      cc  oo      oo  dd      dd
      17$                cc          oo      oo  dd      dd
      18$                cc          oo      oo  dd      dd
      19$                cc          oo      oo  dd      dd
      20$                cc          oo      oo  dd      dd
      21$                cc      cc  oo      oo  dd      dd
      22$                cccccccccc  oooooooooo  dddddddddd
      23$                 cccccccc    oooooooo   ddddddddd
      24$
      25$
      26$         t h e    s e t l    c o d e    g e n e r a t o r
      27$
      28$       this software is part of the setl programming system
      29$                address queries and comments to
      30$
      31$                          setl project
      32$                 department of computer science
      33$                      new york university
      34$           courant institute of mathematical sciences
      35$                       251 mercer street
      36$                      new york, ny  10012
      37$
      38
      39
      40$ this is the final pass of the setl compiler. it translates
      41$ the program from an internal form known as q1 into an internal
      42$ form known as q2. q2 is then used to drive the code generator.
      43$
      44$ the input to the code generator is a single q1 file containing
      45$ code for all the members in the program.
      46$
      47$ the q1 file is divided into a series of 'compilation units' or
      48$ 'units'. a unit is either:
      49$
      50$ 1. a member header
      51$ 2. a procedure
      52$
      53$ the code generator processes units one at a time. its output is
      54$ a single file containing the initial value of the run time heap
      55$ and various auxiliary tables.
      56$
      57$ the code generator consists of three sections:
      58$
      59$ 1. initialization
      60$
      61$    during this phase we initialize various compiler tables
      62$    and zero out the heap.
      63$
      64$ 2. main loop
      65$
      66$    this phase processes each unit on the q1 file. it
      67$    has five parts:
      68$
      69$ 2.1  gettab
      70$
      71$      in this section we read the next page of q1.
      72$
      73$      a page of q1 consists of:
      74$
      75$ 1. the unit type unit_xxx
      76$ 2. a toklen_lim character string giving the name of the unit
      77$ 3. a pointer to the symtab entry for the unit
      78$ 4. the number of procedures in the current member
      79$ 5. the number of the first statement in the unit.
      80$ 6. slices of each of the q1 tables.
      81$
      82$      note that we never write out an entire q1 table. instead we
      83$      write out an array slice which contains all the new entries
      84$      for the current unit.
      85$
      86$      each array slice is identified by two pointers:
      87$
      88$      xxx_org:     pointer to zero-th entry
      89$      xxxp:        pointer to last entry
      90$
      91$      we read array entries from xxx(xxx_org+1) to xxx(xxxp).
      92$
      93$      since we do not read in the entire symbol table,
      94$      information which we still need from previous
      95$      units is not destoyed.
      96$
      97$ they q1 file ends with a special unit with type unit_end and
      98$ items 2-5 above omitted.
      99$
     100$ 2.2 fixup
     101$
     102$      this phase performs peephole optimizations and types
     103$      temporaries. it is only used if the global optimizer
     104$      is unavailable.
     105$
     106$ 2.3  alloc
     107$
     108$      this phase performs storage allocation. we assign
     109$      each variable, etc. in the current unit a symbol table
     110$      address.
     111$
     112$ 2.4  codegen
     113$
     114$      this phase emits the actual q2 code for the unit.
     115$
     116$ 2.5  initevn2
     117$
     118$      this phase initializes the run time symbol table
     119$      entries for constants and static variables in the current
     120$      unit. it must be done after code generation so that
     121$      values of labels are known.
     122$
     123$ 3. termination
     124$
     125$      in this phase we write out the q2 tables.
     126
     127
     128
     129$ treatment of temporaries
     130$
     131$ the semantic pass allocates a unique temporary for each
     132$ instruction. both the optimizer and the fixup phase merge
     133$ temporaries which are never live at the same time.
     134$
     135$ in addition to the temporaries which appear explicitly in
     136$ the q1 code there are temporaries which must be used for
     137$ the results of copies and conversions.
     138$
     139$ the temporaries used for copies and conversions have a life
     140$ of a single instruction. furthermore no instruction requires
     141$ more than three of them. for these reason we allocate three
     142$ standard temporaries and use them for all copies and
     143$ conversions.
     144$
     145$ the names of these temporaries are given by the macros
     146$ t1_, t2_, and t3_. their addresses are given
     147$ by addr_temp1, addr_temp2, and addr_temp3 respectively.
     148
     149
     150
     151$ data structures
     152$ ---------------
     153$
     154$ the data structures for the code generator are divided into four
     155$ groups:
     156$
     157$ 1. the data structures describing q1. these are essentially the
     158$    same data structures used in the semaintic pass except that
     159$    a few symbol table fields are reused.
     160$
     161$ 2. the data structures for q2. these are the run time data
     162$    structures. the macros and declarations for the run time
     163$    data structures are included verbatum from the source
     164$    of the run time library.
     165$
     166$ 3. miscelaneous globals. each time we iterate over the q1 code,
     167$    we unpack the instruction and put information about it
     168$    into a series of global variables.
     169
     170
       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. modify 'cnvcon' to reflect that non-primitive denotations are
bnda   6$     hashed by sem.
bnda   7$     module affected:  cnvcon.
strb   1
strb   2
strb   3$ 07/24/84     84206     s. freudenberger
strb   4$
strb   5$  1. modify intab1 so that nelt, of, and sof on f_sstring and f_string
strb   6$     always emit q2_neltic, q2_ofcl, and q2_sofcl, resp.
strb   7$     module affected:  initab1.
stra   1
stra   2
stra   3$ 07/24/84     84206     d. shields and s. freudenberger
stra   4$
stra   5$  1. support short character strings.
stra   6$     modules affected: getsbs, emconv, and incnst.
stra   7$  2. rename storage class macros sc_xxx to scl_xxx in order to avoid
stra   8$     name conflicts with short character macros.
stra   9$     modules affected: start, alloc, sclass, fsclass, ementry, emexit,
stra  10$                       embentry, and embexit.
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, codini, inienv1, and codtrm.
asca   1
asca   2
asca   3$ 03/05/84     84065     d. shields
asca   4$
asca   5$  1. for s37, support switch ascii=0/1 such that ascii=1 causes
asca   6$     character strings to be generated in the heap in ascii.
asca   7$     this is needed to support nyu ada/ed ada compiler.
asca   8$     modules affected: codini, bldpset, incnst, and initio.
suna   1
suna   2
suna   3$ 03/05/84     84065     s. freudenberger
suna   4$
suna   5$  1. support motorola mc68000 microprocessor on sun workstation.
suna   6$     modules affected: start and codini.
suna   7$  2. correct an error test in the shrtct routine to handle the code
suna   8$     resulting from the fixgo routine in the case of a case statement
suna   9$     where one case ends with a refinement and the next case is null.
suna  10$     replace assert statements by calls to the error message routine.
suna  11$     modules affected: shrtct and ermsg.
suna  12$  3. correct a conversion error for binary set operations.
suna  13$     module affected:  embin.
smfd   1
smfd   2
smfd   3$ 09/01/83     83244     s. freudenberger
smfd   4$
smfd   5$  1. use the new short integer binary file format.
smfd   6$     module affected:  getsbi.
smfd   7$  2. ok_conv is really used for testing whether a conversion might
smfd   8$     succeed or will always succeed.  this, of course, cannot be done
smfd   9$     in one routine.  hence introduce a new routine can_conv which
smfd  10$     checks whether a conversion could succeed, and modify ok_conv
smfd  11$     to succeed if and only if the conversion will always succeed.
smfd  12$     modules affected: sixchar, emconv, and okconv.
smfd  13$     module added:     canconv.
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$     module affected:  getsbi.
smfc   8$  2. modify the form propagation for range set types of ambiguous maps.
smfc   9$     module affected:  rsettype.
mjsa   1
mjsa   2
mjsa   3$ 08/08/83     83220     s. freudenberger and m. smosna
mjsa   4$
mjsa   5
mjsa   6$  1. implement arbitrary precision integer arithmetic.  include
mjsa   7$     the new member 'lipkg' into stlini.
mjsa   8$     module affected:  stlini.
smfb   1
smfb   2
smfb   3$ 08/08/83     83220     s. freudenberger
smfb   4$
smfb   5$  1. change the six character name of match_repr from mtcrep to matchr.
smfb   6$     module affected:  sixchar.
smfb   7$  2. do not write the dead block following the last run-time names
smfb   8$     string block to the q2 file.
smfb   9$     modules affected: start, inienv3, and codtrm.
smfb  10$  3. add a unary predicate q1_pos for use in arithmetic iterators when
smfb  11$     the sign of the increment is not know.  this allows the optimiser
smfb  12$     to detect the special nature of this test easily.  this opcode
smfb  13$     always has sym_zero as a third operand, and is changed during the
smfb  14$     fixup phase to the corresponding q1_lt.
smfb  15$     modules affected: start, fixup, and dblock.
smfb  16$  4. add two new conditional branches to q1:  q1_bif and q1_bifnot.
smfb  17$     this allows the optimiser to recognise whether a conditional
smfb  18$     branch was generated as part of the translation of a boolean
smfb  19$     operation.  no new q2 opcodes are needed for this.
smfb  20$     modules affected: start, fixup, fixnot, fixpred, and dblock.
smfb  21$  5. add a new conditional branch to both q1 and q2 to check the assert
smfb  22$     program parameter and branch if assert=0.  this prevents the
smfb  23$     evaluation of the asserted expression if that is desired.
smfb  24$     modules affected: start, fixup, codegen, and dblock.
smfb  25$  6. add a new routine format_form = formfm which formats a form table
smfb  26$     entry into a repr-syntax string.  use this routine to print a
smfb  27$     message for each non-primitive conversion emitted iff reprs=2 is
smfb  28$     specified.
smfb  29$     new program parameter:
smfb  30$         reprs=1/1     process repr declarations:  if reprs=2, print a
smfb  31$                       message for each non-trivial conversion emitted.
smfb  32$     module affected:  sixchar, start, codini, and emconv.
smfb  33$     module added:     formfm (after mtdump).
smfb  34$  7. add a new routine inidbg to build the is_ovar predicate if debug=1
smfb  35$     is specified.  this predicate is represented compactly as a packed
smfb  36$     tuple(integer 1..1) and is stored in the s_ovar standard run-time
smfb  37$     symbol table entry.  include a call to this routine into inienv3.
smfb  38$     module affected:  inienv3.
smfb  39$     module added:     inidbg (after initio).
smfb  40$  8. add to the inline opcode mapping the opcodes for ambiguous map
smfb  41$     retrievals and the share-retrieval for tuples where the index is
smfb  42$     known to be in range.
smfb  43$     module affected:  initab2.
smfb  44$  9. try to convert short constants to the required form for binary
smfb  45$     oparators and predicates.
smfb  46$     modules affected: fixup, speceq, specin, and specpred.
smfb  47$ 10. change the propagation for short integer forms on assignments.
smfb  48$     module affected:  fixasn.
smfb  49$ 11. correct the code sequence generated for iterators over maps:
smfb  50$     interpret the copy flag, which is set by the optimiser.
smfb  51$     module affected:  codegen.
smfb  52$ 12. correct special casing error on untyped variables in equality
smfb  53$     tests.
smfb  54$     module affected:  speceq.
smfb  55$ 13. correct the code generated for certain legal though unlikely
smfb  56$     operations such as set difference where the right operand cannot
smfb  57$     be converted to the left operand form, or set less element where
smfb  58$     the element cannot be converted to the set element form.
smfb  59$     modules affected: embin and emwith.
smfb  60$ 14. improve the code generated for tuple retrievals and embeddings:
smfb  61$     modify the definitions of the relevant q2 inline opcodes to accept
smfb  62$     long and short integers;  do index range check statically where
smfb  63$     possible;  correct a typo in emsof.
smfb  64$     modules affected: emof and emsof.
smfb  65$ 15. allow the result of a domain or range operation to receive a map
smfb  66$     representation.  this relaxation was needed since the optimiser
smfb  67$     treats all sets of pairs as maps.
smfb  68$     module affected:  emst2.
smfb  69$ 16. pass the copy flag from emasn to emconv if a conversion is needed.
smfb  70$     module affected:  emasn.
smfb  71$ 17. modify the semantic definition of q2_checki1 to check for short
smfb  72$     integer in range.  this means that no q2_checktp needs to precede
smfb  73$     a q2_checki1.
smfb  74$     module affected:  emconv.
smfb  75$ 18. include a range check for short integer constant conversion;
smfb  76$     prevent short integer constant conversion to integer constant.
smfb  77$     module affected:  convcon.
smfb  78$ 19. prevent a new run-time symbol table to be generated for different
smfb  79$     short integer constants.
smfb  80$     module affected:  cnvcon.
smfb  81$ 20. always generate an alternate representation for numeric constants
smfb  82$     as required and appropriate.
smfb  83$     module affected:  matchr.
smfb  84$ 21. modify the forwards form propagation for binary operators on
smfb  85$     primitive forms.
smfb  86$     module affected:  bintype.
smfa   1
smfa   2
smfa   3$ 12/16/82     82350     s. freudenberger
smfa   4$
smfd  14$  1. the recently introduced ft_deref field is used in this phase to
smfa   6$     replace the deref_typ function.
smfa   7$     modules affected: sixchar, start, and most others.
smfa   8$     module deleted:   dereftyp.
smfa   9$  2. run-time names are stored differently:  see compl for an explana-
smfa  10$     tion.  this version is upwards compatible for all implementations.
smfa  11$     iname now has three parameters:  a prefix string, a q1 symbol
smfa  12$     table pointer, and a q2 symbol table address.  care must be taken
smfa  13$     in the future to asure that iname can allocate space in the
smfa  14$     dynamic part of the heap.
smfa  15$     modules affected: start, iname, emdebg, trmcod, inenv1, inenv3,
smfa  16$                       codtrm, alloc, genint, cnvcon, genelt,
smfa  17$                       and bldpset.
      22
      23
      24$ 08/12/82     82224     s. freudenberger
      25$
      26$  1. the q2 definitions have been moved into a separate subroutine
      27$     stlini, whose definition should correspond to the definition of
      28$     libpl.stlini.  this enables us to link cod against stlshr on s32.
      29$     variable declarations global to cod have been placed into the
      30$     nameset nscod, and access statements added as needed.
      31$     modules affected: all.
      32$     module added:     stlini.
      33$  2. the q2 opcodes have been updated:  all aliases and unused codes
      34$     have been eliminated.
      35$     modules affected: initab1 and emconv.
      36$  3. the form table layout has been changed:  the fields 'ft_deref' and
      37$     'ft_imset' have been added.  this fields are included in the sq1
      38$     file.  (fmdump has been replaced for convenience.)
      39$     module affected:  sgettb and fmdump.
      40$  4. a typo has been corrected in the specin routine:  as a result an
      41$     undefined variable had been accessed, causing problems on s37.
      42$     module affected:  specin.
      43$  5. procedure linkage has been modified:  the relevant opcodes specify
      44$     the low-core address of the block to be moved, instead of the
      45$     high-core address.
      46$     module affected:  embentry, embexit, and emmove.
      47$  6. string pattern sets have been defined as a separate entity.  they
      48$     are (still) represented as packed tuples, but are parameterised
      49$     to generate byte tables for r32.
      50$     module affected:  bldpset.
      51$  7. the argument sequence for the q2_entry, q2_exit, and q2_undo
      52$     instructions has been changed:  the code address now occupies the
      53$     codea1 field of the first quadruple (recall that all other code
      54$     addresses use this field, which is larger than the remaining
      55$     fields).  furthermore, the necessary q2_lab instructions are
      56$     emitted if we generate assembly code (asm=1).  finally, the
      57$     routines are relocated when assembly code is generated.
      58$     modules affected: embentry and embexit.
      59
      60
      61$ 06/15/82     82166     s. freudenberger
      62$
      63$  1. code controled by the asm program parameter has been changed as
      64$     follows:
      65$
      66$     1.1 q2 code is generated in the collectable part of the heap.  as
      67$         a consequence, constant pattern sets are allocated in the
      68$         constant part of the heap.
      69$         modules affected: start, bldpset, initcode, em2, and termcode.
      70$     1.2 procedures do not start with a q2_stmt quadruple.
      71$         module affected:  codegen.
      72$     1.3 the first instruction emitted for a non-backtracked procedure
      73$         has been corrected to pentry.
      74$         module affected:  ementry.
      75$     1.4 the implicit start of a basic block after a conditional
      76$         conversion has been made explicit by emitting the required
      77$         q2_lab instructions.
      78$         module affected:  emconv.
      79$  2. branch operations have been optimised further.
      80$     modules affected: fixup, fixgo, and fixpred.
      81$     module added:     shrtct (after fixpred).
      82$  3. div on untyped reals has been eliminated.
      83$     module affected:  initab1.
      84$  4. the mode propagation predicates have been improved for strings.
      85$     modules affected: elmt_type, dom_type, and im_type.
      86$  5. q2_asrt has been changed so that its second operand is the current
      87$     routine name and its third argument is the current statement
      88$     number.  thus no call to find_stmt is needed anymore to print the
      89$     trace message.
      90$     module affcted:  codegen.
      91
      92
      93$ 06/01/82     82152     s. freudenberger
      94$
      95$  1. we added conditional code for the s37 mts implementation.
      96$     module affected:  codini.
      97$  2. a new program parameter has been added to control the generation
      98$     of q2_stmt quadruples:
      99$             stmt=1/2        0: suppress generation of q2_stmt
     100$                                quadruples completely - all run time
     101$                                error messages will diagnose the error
     102$                                to occur in statement one of the
     103$                                correct routine;
     104$                             1: generate q2_stmt quadruples as before,
     105$                                yet move any q2_stmt at the end of a
     106$                                basic block to the start of the next
     107$                                basic block.
     108$                             2: in addition to the q2_stmt generated
     109$                                under stmt=1, generate a q2_stmt after
     110$                                each q2_call instruction and set its
     111$                                codea4 field to one (this quadruple is
     112$                                usefull for dynamic frequency counts).
     113$     modules affected: start, codini, and codegen.
     114$  3. the initialisation of the special q2 opcode for q2_of on long
     115$     character strings (f_string) has been added.
     116$     module affected:  initb1.
     117$  4. 'sgettb' has been modified to account for the new sq1 file format.
     118$     (see sempl for details).
     119$     modules affected: sgettb and fmdump.
     120$  5. conversions involving short integer modes (f_sint's) have been
     121$     modified to reflect the use of ft_low.
     122$     modules affected: emconv, okconv, convcon, canasn, and insamp.
     123$  6. to simplify the machine code generation for setl, the inline code
     124$     for q2_lessflm has been disabled for local maps based on plex
     125$     bases.
     126$     module affected:  emlessf.
     127$  7. the mixed-tuple-table dump routine has been rewritten to produce a
     128$     more compact listing.
     129$     module affected:  mtdump.
     130
     131
     132$ 03/16/82     82075     s. freudenberger
     133$
     134$  1. the initialisation of the special q2 opcode for q2_sof on long
     135$     character strings (f_string) has been corrected.
     136$     this changed the code just a little, yet little enough to show
     137$     a bug in little.  it could be circumvented by moving some code
     138$     from initb1 to initb2, which has been done.
     139$     module affected:  initb1 and initb2.
     140$  2. the initialisation of the special q2 opcodes for sym_true and
     141$     sym_false has been deleted, to correct the bug that 'newat = true'
     142$     causes an execution error.  the q2 opcodes q2_eqtrue, q2_eqfalse,
     143$     q2_eqif, q1_eqifnot, q2_goif, and q2_goifnot are not emitted any
     144$     longer and should be removed as time permits.
     145$     modules affected: initb2 and speceq.
     146$  3. the q1 symbol table flag is_rec is now set by either sem or opt:
     147$     remove the initialisation code.
     148$     module affected:  gettab and sgettb.
     149$  4. the form table field ft_low has been made part of the sq1 file.
     150$     module affected:  sgettb.
     151$  5. the q1 symbol table flag is_memb has been removed from the symbol
     152$     table, and the flag is_init has been added.
     153$     module affected:  sgettb.
     154$  6. a mode propagation bug on internal variables has been corrected:
     155$     the construct 'e1 op/ e2' would miscompile if e1 was a constant
     156$     with a more specific mode than the element mode of e2.  this has
     157$     been corrected using the is_seen q1 symbol table flag for internal
     158$     variables.
     159$     module affected:  fixasn.
     160$  7. we look ahead for q1_free instructions to collect as many of them
     161$     as possible into each q2_free instruction.
     162$     module affected:  codegen.
     163$  8. when we select inline cases for equality test, we take the form of
     164$     both input operands into account to select special cases.  this
     165$     enables us to emit an q2_eqv for equality tests on sym_true and
     166$     sym_false.
     167$     module affected:  speceq.
     168
     169
     170$ 02/01/82     82032     s. freudenberger
     171$
     172$  1. the listing output has been moved to start each line in column 1
     173$     rather than column 7.  dump outputs have not been modified.
     174$     modules affected: codini, inenv1, ermsg, codwrn, overfl, abort,
     175$                       and codtrm.
     176$  2. the line layout for error and warning messages has been modified.
     177$     modules affected: ermsg and codwrn.
     178
     179
     180$ 02/01/82    82032     d. shields
     181$
     182$ use r32 conditional symbol for standard 32-bit fields.
     183$ this replaces the field definitions for s32, s37 and s47.
     184
     185
     186$ 01/15/82     82015     s. freudenberger & d. shields
     187$
     188$  1. codini has been modified to print the phase header to the terminal
     189$     whenever the new control card parameter 'termh=0/1' is set.
     190$     new control card parameter:
     191$         termh=0/1           print phase header on the terminal file
     192$     module affected:  codini.
     193$  2. the case map of a case statement is always repred.  we use this
     194$     knowledge to print better error messages if an error occurs while
     195$     we allocate a casemap.
     196$  3. the map used for second argument of open has been modified so that
     197$     for mixed-case implementations, the argument can be specified in
     198$     lower or upper case.
     199$     modules affected: fixup, incnst, ermsg, and codwrn, initio.
     200
     201
     202$ 11/29/81    81333     d.shields
     203$
     204$  1. support s47: amdahl uts (universal timesharing system).
     205$     this implementation runs on s37 architecture using an operating
     206$     system very close to unix (v7), and uses the ascii character set.
     207
     208
     209$ 81/10/27     81300     s. freudenberger
     210$
     211$  1. the q2 interface has been formalized:  a total of six routines
     212$     read and write a standard q2 file, and a seventh routine
     213$     checks a q2 file to determine whether it is in the correct
     214$     format.
     215$     the routines wrheap, wrheap1, and wrheap2 write the entire
     216$     heap, the environment block, and the heap slices, resp.
     217$     the routine wrheap1 is used in codtrm to write the
     218$     environment block.  specialised code, however, is used to
     219$     write the heap slices since we do not write the dead block
     220$     between the constants area and the heap proper.
     221$     module affected:  codtrm.
     222$  2. for the dec vax vms version we now allocate the heap dynamically.
     223$  3. the setl-fortran interface has been implemented for the
     224$     s32, s37, and s66 versions.
     225$     the interface uses a communication area which is kept as a
     226$     tuple in the setl heap as the symbol intf:  sym_intf replaces
     227$     sym_spare1, and s_intf replaces s_spare1.
     228$     the actual call to fortran is done by the new built-in function
     229$     callf, for which a new q1 symbol table entry and a new q2 opcode
     230$     were needed.
     231$     modules affected: start and inienv3.
     232$  4. the address range of the q2 symbol table is tested whether it
     233$     can be stored in the q2 instructions, and a fatal error message
     234$     is issued if it does not.
     235$     module affected:  inenv1.
     236$  5. the reserved words 'spec' and 'unspec' have been deleted.
     237$     module affected:  start.
     238$  6. if the mode of x cannot be converted to the domain mode of f,
     239$     then a q2_ofa is emitted (and not a q2_of) for a q1_ofa.  this
     240$     typo has been corrected.
     241$     module affected:  emofa.
     242
     243
     244$ 06/24/81     81175     s. freudenberger
     245$
     246$  1. the operator class for predicates, cl_pred, has been split into
     247$     two classes, cl_pred1 and cl_pred2, such that membership tests
     248$     (q1_in and q1_notin) are in cl_pred1, and the remaining predi-
     249$     cates (q1_eq, q1_ne, q1_incs, etc.) are in cl_pred2.  the purpose
     250$     of this destinction is to be able to verify that membership tests
     251$     are defined for plex objects subject to the constraint that the
     252$     element has the proper form, while the other predicates are not
     253$     defined for plex objects (eg. it is impossible to compare two
     254$     plex objects for equality since it is impossible to iterate over
     255$     plex objects).
     256$     modules affected: start, fixup, and codgen.
     257$  2. we introduced a new global variable curmemb, giving the current
     258$     member name (ie. the symbol table index of the current member).
     259$     modules affected: start, gettab, ermsg, and codwrn.
     260$  3. the is_pre setting for q1_exp has been changed to no as there is
     261$     no inline code available.
     262$     module affected:  start.
     263$  4. the operator class for q1_even and q1_odd has been corrected to
     264$     cl_atom, as booleans are the blank atoms 0 and maxsi
     265$     module affected:  start.
     266$  5. we introduced three new q2 opcodes, and renamed one, to implement
     267$     a first part of case map optimisation as outlined in nl. 215.
     268$     the q2 opcodes for q1_case are q2_caset, q2_caselsm, q2_casersm,
     269$     q2_caseusm.
     270$     modules affected: start, intab1, gettab, fixup, codgen, incnst,
     271$     and codwrn.
     272$  6. we introduced several new system global variables, in an effort
     273$     start to implement a dynamic symbolic debugging system.  most
     274$     notably in this phase, we added a new control card parameter,
     275$     debug=0/1, which controls the initialisation of the debugging
     276$     features.
     277$     modules affected: q1symtab, q2opcd, q2vars, codini, emdebg,
     278$     inenv3, and codtrm.
     279$  7. we added the following initialisations to the spec_op map:
     280$     for short integers: q1_min -----> q2_mini
     281$     for map forms:      q1_notin ---> q2_nins
     282$     module affected:  intab1.
     283$  8. we added the following initialisations to the of_op map:
     284$     for smaps, for untyped based maps, for q1_of and q1_sof:
     285$     select the appropriate inline opcode.
     286$     module affected:  intab1.
     287$  9. the file format of the sq1 file has been changed: constants of
     288$     mode f_atom must be the booleans true and false (or symbols
     289$     aliased to these).  the sq1 entry for such a constant now is,
     290$     indeed, a boolean.
     291$     mudule affected:  sgettb.
     292$ 10. the tests for plex objects have been altered substantially, and
     293$     it is hoped that the necessary tests are now performed to use
     294$     plex objects safely.
     295$     modules affected: fixup, fixasn, and emargi.
     296$ 11. the mode backpropagation has been corrected to do backpropagation
     297$     only when the mode to be backpropagated was not obtained by
     298$     forward propagation to a temporary which is the result temporary
     299$     for several conditionally selected blocks (eg. the forward propa-
     300$     gation of the mode of  can not necessarily safely be propa-
     301$     gated back to  in 'if  then  else  end').
     302$     module affected:  fixasn.
     303$ 12. we cannot merge typed and untyped temporaries, since the garbage
     304$     collector must trace typed date, but may not trace untyped data.
     305$     module affected:  settmp.
     306$ 13. we suppress the allocation of a sample value (ie. omega) for
     307$     unbased maps with untyped range modes, since the semantic pass
     308$     checks that no variable can be declared to have such a mode.
     309$     we also suppress to allocate a sample value for the standard
     310$     forms f_elmt and f_latom.
     311$     module affected:  alloc.
     312$ 14. the initialisation of all symbol table entries has been moved
     313$     from the alloc routine to the inenv2 routine.
     314$ 15. we corrected the code generated for q2_free to pop the skip word
     315$     of untyped parameters.  the bug was that cl_free checked the form
     316$     of the actual parameter, rather than the form of the formal para-
     317$     meter, thus producing incorrect results if a conversion between
     318$     typed and untyped data was emitted as part of the call.
     319$     module affected:  codgen.
     320$ 16. we modified the code of the specin routine, without changing the
     321$     code it generates.  the new code calls the dertyp and emconv
     322$     utilities rather than to execute equivalent code inline.
     323$ 17. the emof and emofa routines have been modified to select q2_of
     324$     and q2_ofa, resp., if the third argument cannot be converted to
     325$     the map domain form, rather than to signal an error.  the new
     326$     choice reflects the strict setl semantics, the old choice indi-
     327$     cated that such a retrieval always yields omega and thus is
     328$     constant.
     329$ 18. the emof routine has been modified to only select a share-op if
     330$     the result's form is non-primitive.
     331$ 19. the emsof routine has been modified to always call the library
     332$     if the third argument is untyped, and the second argument not a
     333$     local map.  this is required since all other inline cases poten-
     334$     tially call the library, and untyped data would be incorrect in
     335$     that context.
     336$ 20. the empush routine has been corrected so that is forces a copy
     337$     (ie. a conversion) when local objects are passed as parameters.
     338$     under an earlier semantic definition for formal parameters in
     339$     setl, they could not be modified unless they were declared wr or
     340$     rw.  later this definition was changed, but this hidden optimi-
     341$     sation was not adjusted accordingly.
     342$ 21. the emconv routine has been corrected to handle cases where first
     343$     a dereference operation is needed, followed by a primitive type
     344$     check (eg. let the base b have an element mode of f_gen, let x.in
     345$     have the form 'elmt b', and let x.out have the form f_int:  after
     346$     a one-level dereference, we still need to check that x is an
     347$     integer.  before this modification, this would have been flagged
     348$     as an error).
     349$ 22. the error message for failure to convert to a string has been
     350$     corrected.
     351$     modules affected: emconv and ermsg.
     352$ 23. we modified the form dereference operation to stop with an
     353$     element form if this element is an element of a plex base.
     354$     modules affected: emconv and dertyp.
     355$ 24. we allow a general form to be assigned to a element_of_plex_base
     356$     form, subject to a run-time type check with fatal failure.
     357$     modules affected: q2opcd and emconv.
     358$ 25. we print a warning message for each unsatisfied external proce-
     359$     dure reference found at the end of code generation.
     360$     module affected:  setlb1.
     361$ 26. we print an error message if the input does not include a main
     362$     program, ie. when s$main is undefined.
     363$     module affected:  inenv3.
     364$ 27. the q2 data structure for long atom data blocks has been modified
     365$     to include a field la_form pointing to the form table entry of
     366$     its plex base.
     367$     modules affected: s10q2f, s32q2f, s37q2f, s66q2f, q2flds, and
     368$     insamp.
     369$ 28. the standard form f_lab is initialised to a t_olab rather than to
     370$     a t_oint.  note the correspondence with the garbage collector:
     371$     labels need not be traced since code is stored in the constant
     372$     area, or is dead after machine code has been generated.
     373$     module affected:  insamp.
     374$ 29. the module codwrn has been added after the module ermsg to print
     375$     warning messages.
     376
     377
     378$ 01/05/81     81005     s.tihor
     379$
     380$  1.  update q2 format, including magic number
     381$ 03/20/81     81086     s. tihor
     382$
     383$  1.  add 20 new variables to the symbol table and code file
     384$      to permit extensions without invalidating old code files.
     385$
     386$ 01/29/81     81029     s. freudenberger
     387$
     388$  1. the specin routine has been extended to generate better code for
     389$     based membership tests.
     390$  2. the embin routine has been modified to always copy strings
     391$     before they are used.
     392
     393
     394$ 12/02//80     80337     s. tihor
     395$
     396$ 1. supress dumps to terminal.
     397$ 2. supress dumps when et=0.
     398
     399
     400$ 12/02/80     80337     s. freudenberger
     401$
     402$  1. 'cstmt_count', the cummulative statement counter, and
     403$     'ustmt_count', the cstmt_count at the start of the current
     404$     compilation unit, have been initialized to zero (rather
     405$     than one).  this corresponds to a change in sem.
     406$  2. the setl q1 interface has been modified to account for
     407$     the field overlap of ft_lim, ft_pos, and ft_tup.
     408$  3. the fixnot and fixpred routines have been modified to
     409$     only fold temporaries, and not internal variables, which
     410$     could be constant subexpressions as detected by the
     411$     optimiser.
     412$  3. cl_not and cl_ifgo are handled somewhat more straight-forward
     413$     during the codegen phase.
     414$  4. the emwith routine has been modified to account for the
     415$     not-is_pre of q1_less.
     416$  5. the emlessf routine has been modified to account for the
     417$     is_fmap of the result of the operation.
     418$  6. the optpack routine has been modified to save one word if
     419$     the bit position for the next object is one.
     420$  7. the *yd directive in the insamp deck has been deleted.
     421
     422
     423$ 11/05/80     80310     s. freudenberger
     424$
     425$  1. the operator class cl_st2 has been introduced.  it is used
     426$     for the domain and range operators, which have been modified
     427$     to allow arbitrary set modes as results.  (previously, they
     428$     generated an unbased set, which then had to be converted.)
     429$     modules modified:  start, fixup, fixasn, codegen
     430$     module added:      emst2
     431$  2. the operator table (optab) has been modified to include an
     432$     ops_ovar flag.  this flag marks operators which modify there
     433$     first argument, and is intended to be used to implement the
     434$     variable trace feature.
     435$  3. the initab1 routine has been modified to reflect the changes
     436$     in the sequence of ft_type codes.
     437$  4. the temporary storage overlay routines have been modified to
     438$     account for the fact that the optimizer performs this task.
     439$     modules modified:  fixup, settemp, freetemp, droptemp
     440$  5. the following routines have been modified to convert a set
     441$     t a map:  emof, emofa, emsof, emsofa
     442$  6. the following routines check for same_repr, and not for
     443$     simillar_repr:  seta2, seta3, seta4.
     444$  7. the optpack routine has been written.  related changes to
     445$     the insamp routine have been made.  the basinfo routine
     446$     became superflous, and has been deleted.
     447$  8. the packinfo routine has been updated to reflect the re-
     448$     striction placed on packed integer ranges (integer i .. j
     449$     implies i>0).
     450$  9. the form dump routine has been updated to reflect the
     451$     form table changes described in compl.
     452
     453
     454$ 09/08/80     80252     s. freudenberger
     455$
     456$  1. the fixup and embin routines have been corrected to handle
     457$          a1 := a2 <*binop> a3
     458$     where a1 has not a set mode, and a2 is a local set/map.
     459$  2. the fixup routine has been modified so that the is_backpr flag
     460$     is only set when the temporary is not repr'ed (as might be by
     461$     the optimizer).
     462$  3. the dblock routine has been modified to print the first 14
     463$     (rather than the first 10) characters of each q1 operand.
     464
     465
     466$ 08/18/80     80231     s. freudenberger
     467$
     468$  1. several fields which assumed memory initialization to zero have
     469$     been set to zero explicitly.
     470$  2. the alloc routine checked a zero-table entry: an undefined
     471$     operation in little.  this has been corrected.
     472$  3. the setl q1 interface has been modified to handle strings
     473$     properly (vlen for string constants was always set to 1).
     474$  4. the form propagation and assignment merging for local
     475$     objects had several errors, all of which have been fixed.
     476$  5. the optimizer sets the copy flag for q1_next instructions,
     477$     indicating when an unconditional copy of the first argu-
     478$     ment is required.  the codegen routine has been modified
     479$     to interpret this field if the opt_flag is set.
     480$  6. the first input of cl_with and cl_lessf is used destruc-
     481$     tively.  unless the o-variable is the first i-variable,
     482$     this requires unconditional copy.
     483
     484
     485$ 08/01/80     80214     s. freudenberger
     486$
     487$  1. initab1 and emofa have been modified to emit off-line code
     488$     for q1_ofa on non-m-maps.  (this corrects a bug, where an
     489$     in-line code sequence was emitted for an s-map.)
     490$  2. the setting of sflag for cl_ssubst operators is never tested:
     491$     drop the setting.
     492$  3. a new global variable has been introduced:  stmt_tot.  it is
     493$     used to count the number of q2_stmt quadrupels emitted, and
     494$     is printed with the q2 statistics upon completion of cod.
     495$  4. the new conditional assembly member of compl replace the
     496$     corresponding section in member start.
     497$  5. the code pointer (codep) has been included into the nameset
     498$     nsgparam.  consequently no declaration is needed in member
     499$     start anymore.
     500$  6. the pre_flag, long dead, has been eliminated.
     501
     502
     503$ 07/10/80     80192     s. freudenberger
     504$
     505$  1. the a_share_op and eq_op tables are initialized to zero, rather
     506$     than rely on initial zero memory.
     507$  2. fixasn has been modified to propagate the dereferenced mode
     508$     to the temporary of an enumerative set- or tuple former.
     509$     this optimization was lost during the modifications of the
     510$     last correction set.
     511$  3. the operator class for q1_incs has been changed to cl_pred.  this
     512$     required the introduction of the following q2 opcodes:  q2_nincs
     513$     and q2_gonincs.
     514$     nb. q2_nincs currently is not emitted.  generally, however, all
     515$     predicates are available in four forms: positive and negated, as
     516$     predicates and as control primitives.
     517$     this change also required the introduction of the following
     518$     q1 opcodes:  q1_ifinc and q1_ifsub.  they are used between the
     519$     fixup and code generation phases to mark where control primitives
     520$     should be used instead of predicates.
     521$  4. some code has been moved within the embin routine:  the code
     522$     generated there now passes the standard test library with
     523$     reprs=1 and rem=4.
     524$  5. a q2_error instruction is now emitted for every q1_error
     525$     instruction as well as for every error diagnosed in a
     526$     procedure scope during this phase.
     527$  6. the number of reserved files for the library has been
     528$     decreased to three (from five):  the string file used by val
     529$     str is not needed anymore by these routines, and the statis-
     530$     tics file is currently not needed.  should it be needed in
     531$     the future, it can re-use the q2 file id.
     532
     533
     534$ 07/08/80     80190     s. freudenberger
     535$
     536$  1. the mode propagation mechanism has been revisited, and changed
     537$     considerably.  it now performs backpropagation only for the
     538$     temporaries defined by set- and tuple formers.  (the backpr flag
     539$     is used to mark such temporaries.)
     540$  2. the mode propagation around mixed tuples has been corrected.
     541$  3. once again, efforts have been made to synchronize statement
     542$     numbers between the parser, semantic pass, code generator,
     543$     and the run-time library.  this time it is done by recording
     544$     the cummulative statement number of the q1_entry instruction,
     545$     an resetting the cstmt_count to this number when a q1_entry
     546$     is seen.
     547$  4. cl_asrt has been introduced.  this allows us to generate the
     548$     conversion which might be needed for the i-variable of the
     549$      assert statement.
     550$  5. the get_addr macro has been modified to return 0 if the q1 symtab
     551$     index is zero, rather than the address(0), which stricly speaking
     552$     is an array reference out of bounds.
     553$  6. a bug in the genelmt routine has been corrected.
     554$  7. the incnst routine has been modified to detect errors in
     555$     set- and tuple formers, such as an smap being multi-valued at
     556$     some point.
     557$  8. the line "no errors..." is not echoed to the terminal anymore.
     558$  9. the layout of the title line has been changed.
     559
     560
     561$ 06/20/80     80172    s. freudenberger
     562$
     563$  1. a bug related to the global string specifiers has been corrected.
     564$  2. a bug in the code sequence generated for sinister subtrings has
     565$     been corrected.
     566$  3. several inline code sequences are now being emitted.  these
     567$     opcodes had been included before, but were never (or rarely
     568$     ever) emitted.
     569$  4. the emst routine has been modify to call the emconv routine if
     570$     it can not assign the set/tuple to the output variable.
     571$     (though it knows that the only legal conversion is a locate)
     572
     573
     574$ 06/06/80     80158     s. freudenberger
     575$
     576$  1. the is_pre flag has been re-introduced (after it had been dropped
     577$     with version 79248).  this time, however, it is tested at a more
     578$     appropriate place, and proper code is emitted.
     579$  2. the code generated for cl_min has been corrected.
     580$  3. the code generated for 'increment integer' has been improved to
     581$     avoid the generation of the '1' in the proper form.
     582$  4. the result of adding two known-length tuples has been corrected
     583$     to 'tuple(general)'.
     584
     585
     586$ 05/29/80     80150     s. freudenberger
     587$
     588$  1. the hash table header data structure introduced with 80130 has
     589$     been incorporated into the compiler and run-time environment.
     590$     decks affected: insamp, getht
     591$  2. more fields are set to zero in 'insamp'.  still, the work is
     592$     incomplete.  this work is done so that eventually there is no
     593$     need to zero the heap.
     594
     595
     596$ 05/27/80     80148     s. freudenberger
     597$
     598$  1. the fixup routine has been modified to accept the cflag setting
     599$     produced by the optimizer.
     600
     601
     602$ 05/09/80     80130     s. freudenberger
     603$
     604$  1. the is_ebfree flag has been eliminated.
     605$  2. equality tests on elements of the same base generate a
     606$     pointer equality test rather than a value equality test.
     607$  3. the seta2 routine had a typo corrected, which tested the
     608$     retrieval rather than the store operation when deciding
     609$     whether the copy flag refers to the second argument.
     610$  4. the q1_query, q1_isprim, q2_query, and q2_isprim operators
     611$     have been eliminated.
     612
     613
     614$ 04/16/80     80107     s. freudenberger
     615$
     616$ when a setl q1 file is given, only the setl q1 file is opened and
     617$ read, and the little q1 file is ignored.  if no setl q1 file is
     618$ given, the file given as little q1 file is opened and read.
     619$
     620$ the inienv1 routine assumes that the h-parameter is given in kilo
     621$ words if it is less than 1024.   the range test, however, checked
     622$ for 0 < h ! h < 1024.  this clearly should be 'and', and has been
     623$ corrected accordingly.
     624
     625
     626$ 04/11/80     80102     d. shields
     627$
     628$ 1. delete cdc update yankdeck directives.
     629$ 2. support second argument to 'open' as described in user manual.
     630$    this involves adding 'text-in', 'binary-out', etc.
     631$ 3. avoid use of '0' null file. this needed since s10 env does
     632$    not support this.
     633
     634
     635$ 04/09/80     80100     s. freudenberger
     636$
     637$ 1. the mode propagation for map retrieval, map store, and parameter
     638$    passing has been improved.
     639$ 2. the string specifiers for the 'move-character' macro are allo-
     640$    cated at a more appropriate place, namely after the heap has
     641$    been allocated.
     642$ 3. three errors around special casing on mixed tuples have been
     643$    corrected: we do not emit inline code for with, fromb, and frome.
     644$    we do, however, emit inline code for sof provided the index is
     645$    constant and in range.
     646
     647
     648$ 02/04/80     80035     s. freudenberger and d. shields
     649$
     650$ 1. implement unary operators acos, asin, atan, char, cos, exp,
     651$    log, sin, sqrt, tan and tanh.
     652$ 2. implement binary operators atan2 and interrogation (?).
     653$ 3. implement type predicates is_atom, is_boolean, is_integer,
     654$    is_map, is_real, is_set, is_string and is_tuple.
     655$    change prim to is_primitive.
     656$ 4. add procedure host() to provide means for adding
     657$    implementation- or site-dependent features.
     658$ 5. a new q1 operator code class has been added:  cl_bool.  it
     659$    is used for operations which yield a boolean.
     660$ 6. depending on the 'et' control card parameter, a message is
     661$    printed at the start of each unit, stating the name of the
     662$    unit.
     663$ 7. 'fixup' and 'codegen' have been modified to reflect the absence
     664$    of the cumulative statement count as the first argument of a
     665$    q1_stmt instruction.
     666$ 8. 'fixasn' has been corrected to use a form as argument to a form
     667$    predicate.
     668$ 9. the assignment after a q1_newat instruction is merged in 'fixasn'.
     669$ 10. the forms propagated to the result temporary in 'fixnot' and
     670$     'fixpred' has been changed from f_gen to f_atom.  note that
     671$     the short atoms 0 and maxsi are used for true and false, resp.
     672$ 11. 'initname' has been corrected to access the run-time names
     673$     table properly when names are stored over several words.
     674$ 12. the code sequences emitted for q1_with and q1_sof have been
     675$     corrected for mixed tuples.
     676$ 13. compile-time conversions between integer constants have been
     677$     corrected.  decks affected: okconv and convcon.  (the problem
     678$     found was improper handling of conversions to short integers.)
     679$ 14. the run-time names entry in 'genelmt' is initialized.
     680$ 15. addressability range checks have been included in 'uselab'
     681$     and 'setlab'.
     682
     683
     684$ 01/21/80     80021     s. freudenberger
     685$
     686$ 1. the form table limit has been increased for the s32.
     687$ 2. addressability checks have been added to avoid field overflows
     688$    for code- and symbol table pointers.
     689
     690
     691$ 01/17/79     80017     s. freudenberger
     692$
     693$ the layout of the heap has been changed:  snames has been integrated
     694$ into the heap at the low core end, and the run-time symbol table has
     695$ been allocated between the run-time names and the constant  part  of
     696$ the heap.  accordingly, a new parameter has been  added  to  specify
     697$ the initial size of the symbol table: st.  note that we observe that
     698$ the names table size is a function of the symbol table size; we thus
     699$ waste actually less space than before, even if we waste it more  vi-
     700$ sibly.
     701$ modules affected:  start, codini, alloc, initname,  genint,  cnvcon,
     702$ genelmt, bldpset, inienv1, inienv3, and codtrm.
     703
     704
     705$ 01/16/79     80016     s. freudenberger
     706$
     707$ 1. all assert statements have been replace by calls to ermsg.
     708$ 2. the dummy routines garbcol etc. have been updated to the current
     709$    routine names.
     710
     711
     712$ 01/15/79     80015     s. freudenberger
     713$
     714$ 1. the std_op-field of optab for q1_date has been corrected.
     715$ 2. the domain forms are propagated to unrepred temporaries during
     716$    fixup for the classes cl_of, cl_ofa, cl_sof, cl_sofa, and
     717$    cl_argin.
     718$ 3. codegen-case cl_stmt checks whether the next quadruple is a
     719$    statement quadruple as well, and suppreses generation of the
     720$    current quadruple if this condition is met.
     721$ 4. emconv has been corrected to assign the proper omega if the
     722$    input is sym_om.
     723$ 5. the q2_share is suppressed for the third argument of q1_of and
     724$    q1_ofa quadruples.
     725
     726
     727$ 12/17/79     79351     s. freudenberger
     728$
     729$ 1. conditional assembly 'sq1' has been introduced, selecting the
     730$    availability of the setl q1 interface.
     731$ 2. the double negation for 'cl_if' has been eliminated.
     732$ 3. 'speceq' has been amended to emit the recently introduced opcodes
     733$    'eqtrue', ...
     734$ 4. 'insamp' now initialized more fields to zero than it did before.
     735$    this work was started to eliminate the need to zero memory for the
     736$    heap, but is not yet completed.
     737
     738
     739$ 11/30/79     79334     s. freudenberger
     740$
     741$ 1. the special casing for equality tests on elements has been
     742$    corrected.
     743$ 2. four new q2 opcodes for equality testing have been introduced
     744$    to handle booleans inline.  code addition to actually emit
     745$    these codes has not yet been added.
     746$ 3. some minor bugs with the setl q1 interface have been corrected.
     747$ 4. 'emconv' has been corrected to (a.) handle null set and null
     748$    tuple conversions to f_elmt correctly, and to (b.) observe
     749$    the proper copy semantic after dereferencing f_elmt's.
     750$ 5. conditional code has been added to reset the initial heap
     751$    dimension for statically allocated heaps (i.e. s32 and s37)
     752$    if these values are improperly specfied by the user.
     753$ 6. 'compntype' has been corrected to handle strings properly.
     754
     755
     756$ 11/12/79     79316     s. freudenberger
     757$
     758$ 1. fr2.1.014 (debug rdump failure) has been fixed.
     759$ 2. deck 'codini' has been cleaned up.  the q1sd, q1cd, q2sd, q2cd
     760$    control card parameters have been renamed cq1sd, cq1cd, cq2sd,
     761$    and cq2cd, resp.
     762$ 3. the h- and ca- control card parameters are now processed in
     763$    inienv1.  there phase heading line is printed there as well.
     764$ 4. the setl binary i/o interface has been implemented.
     765$ 5. the unit_xxx codes have been corrected.
     766
     767
     768$ 09/13/79     79256     s. freudenberger
     769$
     770$ 1. logical file names are sized using 'filenamlen' (defined in
     771$    cmnpl.sysmac)
     772
     773
     774$ 09/05/79     79248     s. freudenberger
     775$
     776$
     777$ this correction set installs setl 2.1
     778$
     779$
     780$  1. various tables have been updated to reflect the addition
     781$     of q1 and q2 opcodes.
     782$  2. form propagation for 'from',... has been corrected.
     783$  3. the form propagation for iterators has been improved.
     784$  4. the 'is_pre' flag has been obliviated.  this was necessary,
     785$     since its use caused improper code to be generated.
     786$  5. the introduction of booleans means that we now have a number
     787$     of special opcodes (such as goom) which are of questionable
     788$     value.  we do, however, emit proper code for constructs such as
     789$     'if  then...'.
     790$  6. we now emit a q2_stmt at the beginning of each basic block if
     791$     this block is inside the range over which measurements are
     792$     being taken.
     793$  7. 'emfrom' has been updated to reflect that we now have 'from',
     794$     'fromb', and 'frome'.
     795$  8. 'emofa' has been corrected to select the proper inline sequence
     796$     for variables which are not known to be multi-valued.
     797$  9. 'emsof' and 'emsofa' now emit the proper code sequence for
     798$     any necessary left-hand side conversion.
     799$ 10. the second argument for 'q2_checki1' is not an immediate operand
     800$     anymore, since this caused problems when the garbage collector
     801$     adjusted the heap size.
     802$ 11. 's_types' now is initialized properly.
     803
     804
     805$ 07/25/79     79206     s. freudenberger
     806$
     807$ 1. 'typetab' is initialized with a data statement rather than at
     808$    run time.
     809$ 2. 'emsof' converted the third operand to the improper form.  this
     810$    has been corrected.
     811$ 3. the sample value for remote sets are allocated for 'rs_bpw-1'
     812$    bits, since this is the smallest possible allocation, and 'rs_maxi'
     813$    is set to this value.
     814
     815
     816$ 07/20/79     79201     s. freudenberger
     817$
     818$ 1. 'optab' is initialized via a data statement, and not at the start
     819$    of execution.
     820$ 2. form propagation during both the fixup- and the code-generation
     821$    phases has been corrected an improved.  proper code is generated
     822$    to assert run-time consistency between the form a variable and
     823$    its value.
     824$ 3. error messages on the s10 are written to the device 'tty:' rather
     825$    than the file 'tty'.  furthermore, they are preceded by '?', the
     826$    standard error marker for the dec-10.
     827$ 4. error messages on the s32 are written, by default, to 'sys$error'.
     828$ 5. 'codini' prints a line 'start...' on the terminal.
     829$ 6. a deck 'sixchar' has been added, mapping routine names into unique
     830$    six character alphameric names which start with an alphabetic.
     831
     832
     833$ 05/18/79     79138     s. freudenberger
     834$
     835$ 1. the symbol table is initialized to om, unless it is defined
     836$    otherwise.  this way it is not necessary to zero the heap.
     837$ 2. more shared code has been moved into compl.
     838$ 3. constant strings are allocated in the dynamic part of the heap,
     839$    so that they can be shared properly.
     840$ 4. in an if-expression, the result temporary is defined on first
     841$    encounter.
     842
     843
     844$ 04/27/79     79117     s. freudenberger
     845$
     846$ 1. the heap is written onto the q2 file in slices, skipping the
     847$    uninitialized parts between the constant and the dynamic part,
     848$    and between the heap and the stack/symbol table.
     849$ 2. the q1 symbol table data structures and the form table data
     850$    structures have been placed into a common library, since these
     851$    definitions are shared between several phases of the compiler.
     852$    they are now included from an inclusion library.
     853$ 3. to further compact the output produced by this phase, no message
     854$    is printed anymore at the start of each unit.  corresponding
     855$    change have been made so that error messages and dumps still
     856$    can be identified.
     857
     858
     859$ 04/12/79     79102     s. freudenberger and d. shields
     860$
     861$ the control card parameters -h- an -ca- are assumed to be given
     862$ in k-words in the event that they are smaller than 1000.
     863
     864
     865$ 04/10/79     79100     s. freudenberger
     866$
     867$ the dimension of the symbol table has been increased to 1500
     868
     869
     870$ 04/03/79     79093     s. freudenberger
     871$
     872$ as a first step to remove prefix stropping, the pre control card
     873$ parameter has been deleted, and the pre_flag initialized to
     874$ reserved word stropping.
     875
     876
     877$ 03/27/79     79086     s. freudenberger
     878$
     879$ 1. code will only be generated for units of type procedure.
     880$ 2. -alloc- has been corrected so that the indices of arrays
     881$    are defined before they are used.
     882$ 3. the size of the -names- table has been increased to 1500.
     883
     884
     885$ 03/15/79     79074     s. freudenberger
     886$
     887$ 1. the q1 tables are read in in the same sequence in which
     888$    the optimizer writes them out (which, of course, is the
     889$    same sequence in which the semantic pass writes them).
     890$ 2. the name of constant pset-s are prefixed by -p.- rather than
     891$    -pset.-.
     892
     893
     894$ 03/05/79     79065     s. freudenberger
     895$
     896$ 1. the following changes have been made to the debug statement
     897$    options:
     898$
     899$    1.1 three new options have been introduced to allow local dumps
     900$        during code generation:
     901$            cq1cd     q1 code dump during fixup
     902$            cq1sd     q1 symbol table dump during codegen
     903$            cq2cd     q2 code dump during code generation
     904$    1.2 two semantic pass options have been renamed:
     905$            q1dump ----> sq1cd
     906$            symdump ---> sq1sd
     907$
     908$ 2. the statement numbering has been cleaned up.  hopefully error
     909$    messages will print now the statement number corresponding to
     910$    the source listing...
     911
     912
     913$ 02/12/79     79043     a. grand and s. freudenberger
     914
     915$ 1. it moves the value of the dimension macro for the names table
     916$    into a conditional assembly, cooresponding to the definition
     917$    of names_dim in the semantic pass.
     918$ 2. it inserts a notrace entry little directive before the first
     919$    procedure so that no entry trace will be produced for the
     920$    code generator.
     921$ 3. it defines the temporary which is generated for the lhs of the with
     922$    operation in -f@x\ with y-.
     923
     924
     925$ 01/30/79     79030     a. grand and s. freudenberger
     926
     927$ 1. fix-up phase
     928
     929$ 1.1 the op-classes sof, sofa, and ssubst do not return the first
     930$     argument anymore if it is a temporary, since this temporary
     931$     is both input and output.
     932$ 1.2 when we merge temporaries, we check whether we have seen this
     933$     temporary before, and if so, we check whether the forms of the
     934$     different occurrences are equal.  if they are not, we propagate
     935$     f_gen.
     936
     937$ 2. we changed the symdump routine to dump all fields.
     938
     939
     940$ 12-27-78     78361     a. grand and d. shields
     941
     942$ this mod installs machine dependent code for the ibm-370, dec-10,
     943$ and vax. it also fixes the following bugs:
     944
     945$ 1. the copy flags for binary operators are now set properly.
     946$ 2. sample values for packed tuples and maps are built properly.
     947$ 3. conversions to short integer are handled properly.
     948
     949
     950$ 12/08/79     79342     a. grand
     951
     952$ 1. there were several questions involving union, with, and f@x\ := y
     953$    on smaps. these bugs have all been cleaned up.
     954$ 2. several bugs in the compile-time conversion of symbolic constants
     955$    have been fixed.
     956$ 3. conversions on primitive types are now done correctly and handle
     957$    the case where the input is omega.
     958$ 4. 'psets' used for string primitives are now represented as
     959$     packed tuple(1 ... 1).
     960$ 5. we fixed a bug in set_a1 which caused 'f(x) := f' to create
     961$    a circular structure.
     962$ 6. we added a parameter to set_a2 and set_a3.
     963
     964
     965
     966$ 11-15-78     78319     a. grand and s. freudenberger
     967
     968$ 1. fixup phase
     969
     970$    a. we have changes 'fixasn' so that we emit an unconditional
     971$       copy for 'a := b + c' and a conditional copy for
     972$       'a := a + c'.
     973$    b. we have changes the handling of 's := iterative-set-former'.
     974$       we no longer eliminate the temporary yielded by the
     975$       set former. we merely propagate the type of 's' back to
     976$       the temporary and propagate the element type of 's' to
     977$       the temporary used for the set's elements.
     978
     979$ 2. temporary allocation
     980
     981$    a. temporaries with their is_back field set are not merged.
     982$    b. we have added a symbol table field 'is_alias' which is
     983$       true for all temporaries t1 which are used as the alias
     984$       of some other temporary t2.
     985
     986$ 3. code generation
     987
     988$    1. embexit now emits a 'stop' instruction at the end of the
     989$       main program.
     990$    2. we have fixed 'set_a1' to handle 'f(x) := f' and
     991$       'f@x\ := f' properly.
     992
     993$ 4. we have fixed the treatment of statement numbers in the q1 code.
     994
     995$ 5. we have cleaned up the printing of control card parameters on
     996$    the listing.
     997
     998
       1 .=member sixchar
       2
       3
       4$ this deck maps routine names into unique six character names
       5$ starting with an alphabetic, and consisting of alphamerics only.
       6
       7      +*  initab1             =  intab1            **
       8      +*  initab2             =  intab2            **
       9      +*  fixpred             =  fxpred            **
      10      +*  temptab             =  tmptab            **
      11      +*  set_temp            =  settmp            **
      12      +*  free_temp           =  fretmp            **
      13      +*  drop_temp           =  drptmp            **
      14      +*  clear_temps         =  clrtmp            **
      16      +*  fsclass             =  fclass            **
      17      +*  codegen             =  codgen            **
      18      +*  spec_eq             =  speceq            **
      19      +*  spec_in             =  specin            **
      20      +*  spec_pred           =  specpr            **
      21      +*  ementry             =  ement             **
      22      +*  embentry            =  embent            **
      23      +*  embexit             =  embexi            **
      24      +*  emsucceed           =  emsced            **
      25      +*  emlessf             =  emlsf             **
      26      +*  emnewat             =  emnewt            **
      27      +*  emargin             =  emargi            **
      28      +*  emargout            =  emargo            **
      29      +*  emsubst             =  emsubs            **
      30      +*  emssubst            =  emssub            **
smfd  15      +*  can_conv            =  cancnv            **
      31      +*  ok_conv             =  okconv            **
      32      +*  convcon             =  convcn            **
      33      +*  genelmt             =  genelt            **
      34      +*  bldpset             =  bldpst            **
      35      +*  can_assign          =  canasn            **
smfb  87      +*  match_repr          =  matchr            **
      37      +*  set_a1              =  seta1             **
      38      +*  set_a2              =  seta2             **
      39      +*  set_a3              =  seta3             **
      40      +*  set_a4              =  seta4             **
      41      +*  emdebug             =  emdebg            **
      42      +*  initcode            =  incode            **
      43      +*  termcode            =  trmcod            **
      44      +*  setlab1             =  setlb1            **
      45      +*  inienv1             =  inenv1            **
      46      +*  inienv2             =  inenv2            **
      47      +*  optpack             =  optpck            **
      48      +*  inienv3             =  inenv3            **
      49      +*  packinfo            =  pckinf            **
      50      +*  bin_type            =  bintyp            **
smfa  18      +*  deref_typ           =  ft_deref          **
      52      +*  elmt_type           =  elmtyp            **
      53      +*  dom_type            =  domtyp            **
      54      +*  im_type             =  imtype            **
      55      +*  cn_type             =  cntype            **
      56      +*  compn_typ           =  comtyp            **
      57      +*  rset_type           =  rsttyp            **
      58      +*  arg_type            =  argtyp            **
      59      +*  symdump             =  symdmp            **
      60      +*  valdump             =  valdmp            **
smfb  88      +*  format_form         =  formfm            **
      61      +*  dblock              =  dmpblk            **
      62      +*  namesds             =  namsds            **
      63
      64
       1 .=member stlini
       2      subr stlini;
       3
       4 .+set part1
       5
       6 .=include cndasm             $ conditional assembly symbols
       7 .=include sysmac             $ machine parameters
       8
       9 .=include formtab            $ form table
      10
      11 .=include q2flds             $ q2 field definitions to access heap
      12 .=include q2opcd             $ q2 opcodes
      13 .=include q2macs             $ (general) q2 macros
      14 .=include q2vars             $ q2 variables
      15 .=include binio              $ setl binary i/o
mjsa   9 .=include lipkg              $ long integer arithmetic package
      16 .=include measpkg            $ measurement package
      17
      18      end subr stlini;
       1 .=member start
       2 .+s10 prog stlcod;
       3 .+s20 prog stlcod;
       4 .+r32 prog stlcod;
       5 .+s66 subr start;
       6
       7$ in this section we define all the data structures of the code
       8$ generator. we begin with a few meta macros and utilities.
       9
      10      +* prog_level =  $ program level(julian date of last fix)
bnda   8          'cod(85007) '
      12          **
      13
      14
      15
      16
      17$ q1 data structures
      18$ ------------------
      19
      20$ the following data structures are used for q1.
      21
      22
      23 .=include q1symtab
      24 .=include q1code
      25
      26$ n.b. we do not include the form table into the following macro since
      27$ it is relevant to both q1 and q2, and hence defined separately.
      28
      29      +* q1vars =             $ namesets which define q1
      30          nssymtab,           $   -  q1 symbol table
      31          nsq1code            $   -  q1 code table
      32          **
      33
      34$ the code generator uses some additional q1 opcodes between the
      35$ fixup- and code generation phases.  define these additional codes
      36$ here
      37
      38      macdrop(q1_maximum)
      39
      40      defc(q1_ifeq)           $ if a2 = a3 goto a1
      41      defc(q1_ifne)           $ if a2 /= a3 goto a1
      42      defc(q1_ifge)           $ if a2 ge a3 goto a1
      43      defc(q1_iflt)           $ if a2 lt a3 then goto a1
      44      defc(q1_ifin)           $ if a2 in a3 then goto a1
      45      defc(q1_ifnin)          $ if a2 notin a3 then goto a1
      46      defc(q1_ifinc)          $ if a2 incs a3 goto a1
      47      defc(q1_ifsub)          $ if a2 subset a3 goto a1
      48
      49      +*  q1_maximum  =  q1_ifsub  **  $ maximum opcode
      50
      51
      52      nameset nscod;          $ nameset with variables for cod phase
      53
      54$ the opcodes are divided into classes depending on how they are
      55$ handled by the code generator.
      56
      57 .=zzyorg z
      58
      59      defc(cl_simp)           $ trivial cases
      60      defc(cl_noop)           $ noop
      61      defc(cl_min)            $ min and max
      62      defc(cl_lessf)          $ lessf
      63      defc(cl_umin)           $ unary minus
      64      defc(cl_int)            $ yield int
      65      defc(cl_real)           $ yield real
      66      defc(cl_str)            $ yield string
      67      defc(cl_bool)           $ yield boolean
      68      defc(cl_uset)           $ yield set(*)
      69      defc(cl_not)            $ not
      70      defc(cl_rand)           $ rand
      71      defc(cl_arb)            $ arb
      72      defc(cl_stmt)           $ statement number
      73      defc(cl_call)           $ calls
      74      defc(cl_goto)           $ goto
      75      defc(cl_ifgo)           $ conditional gotos
      76      defc(cl_ifgo1)          $ conditional gotos with two inputs
      77      defc(cl_case)           $ case jump
      78      defc(cl_lab)            $ labels
      79      defc(cl_entry)          $ routine entry
      80      defc(cl_exit)           $ roitine exitue
      81      defc(cl_bin)            $ binary operation +, -, *, /, and //
      82      defc(cl_with)           $ with and less
      83      defc(cl_from)           $ from
      84      defc(cl_pred1)          $ membership tests
      85      defc(cl_pred2)          $ binary predicates
      86      defc(cl_asrt)           $ test program assertion
      87      defc(cl_nelt)           $ nelt
      88      defc(cl_newat)          $ newat
      89      defc(cl_of)             $ f(x)
      90      defc(cl_ofa)            $ f<>
      91      defc(cl_subst)          $ subst and send
      92      defc(cl_sof)            $ f(x) := y
      93      defc(cl_sofa)           $ f<> := y
      94      defc(cl_ssubst)         $ ssubst and ssend
      95      defc(cl_argin)          $ argument push
      96      defc(cl_argout)         $ argument pop
      97      defc(cl_push)           $ q1_push
      98      defc(cl_free)           $ free stack space
      99      defc(cl_asn)            $ x := y
     100      defc(cl_next)           $ q1_next and q1_inext
     101      defc(cl_nextd)          $ nextd and inextd
     102      defc(cl_st)             $ enumerative set/tuple former
     103      defc(cl_st1)            $ set1 and tup1
     104      defc(cl_st2)            $ domain/range
     105      defc(cl_ok)             $ ok
     106      defc(cl_fail)           $ fail
     107      defc(cl_succeed)        $ succeed
     108      defc(cl_debug)          $ run time debugging requests
     109
     110
     111      +*  cl_minimum  =  cl_simp  **
     112      +*  cl_maximum  =  cl_debug **
     113
     114
     115$ there are several pointers to the q2 tables which are only needed
     116$ at compile time:
     117
     118      size code_org(ps);      $ pointer to start of current code block
     119      data code_org = 0;
     120
     121      size code_tot(ps);      $ total size of q2 code
     122      data code_tot = 0;
     123
     124$
     125$ the heap is organized as follows:
     126$
     127$             high core
     128$
     129$     t, savet -->                (stack initially empty)
     130$     h_lim -----> +---------+
     131$                  i/////////i
     132$                  i/////////i
     133$                  >=========<     free storage
     134$                  i/////////i
     135$     h ---------> i/////////i
     136$                  i         i
     137$                  i         i
     138$                  >=========<     heap proper
     139$                  i         i
     140$                  i         i
     141$     h_org -----> i         i
     142$                  i/////////i
     143$                  i/////////i
     144$                  >=========<     storage for constants and code
     145$                  i/////////i
     146$     h_const ---> i/////////i
     147$                  i         i
     148$                  >=========<     constants and interpretable code
     149$                  i         i
     150$     ca_org ----> i         i
     151$     sym_end ---> i         i
     152$                  i         i
     153$                  >=========<     symbol table
     154$                  i         i
     155$     sym_lim ---> i         i
     156$                  i/////////i
     157$                  >=========<     storage for symbol table
     158$     sym_org ---> i/////////i
     159$     snam_end --> i         i
     160$                  i         i
     161$                  >=========<     run-time names table
     162$                  i         i
     163$                  i         i
     164$                  i/////////i
     165$                  >=========<     storage for run-time names table
     166$                  i/////////i
     167$     snam_org --> +---------+
     168$
     169$ the stack and heap both grow towards the middle of the free
     170$ storage area. the garbage collector uses the gap between the
     171$ stack and the heap as a work space. when this gap reaches the
     172$ value 'min_gap' we call the garbage collector.
     173$
     174$ the symbol table contains one location for each variable, constant,
     175$ and base. it also contains an entry for each unique data type
     176$ which is used to store the standard representation for omega
     177$ for that type.
     178$
     179$ the low order end of the heap is reserved for constants. a data
     180$ block can be stored in the constants area if it meets three
     181$ conditions:
     182$
     183$ 1. it is live throughout the entire program.
     184$ 2. it is never modified during execution.
     185$ 3. it contains no pointers into the remainder of the heap.
     186$
     187$ the constants area is ignored by the garbage collector, and is
     188$ never compacted. pointers into this area are considered to be null
     189$ and are never traced. this means that the null pointer at the end
     190$ of a list need not be zero; it can be any small integer, say the size
     191$ of an element block.
     192$
     193$ the code generator builds some blocks which can go in the constants
     194$ area and some which cannot. the break down is as follows:
     195$
     196$ block type               where stored     why
     197$ ----------               ------------     ---
     198$
     199$ code                     constants area   never modified
     200$ bases                    dynamic area     modified at run time
     201$
     202$ primitive constants      constants area   never modified at run time
     203$ constant sets + tuples   dynamic area     may point to bases
     204$
     205$ all omega values are typed, i.e. 'omega set', 'omega real' and are
     206$ stored with the constants of the appropriate type.
     207$
     208$ there are two ways to build the heap:
     209$
     210$ 1. build all the blocks which go in the constants area then build
     211$    all the blocks which go in the dynamic area. in order to do this
     212$    we must either make two passes through the q1 file or keep the
     213$    entire q1 symbol table in core through code generation.
     214$
     215$ 2. build all the blocks for one unit, then all the blocks for the
     216$    second unit. in order to do this we must estimate the size of the
     217$    constants area in advance and reserve space for it. if we run out
     218$    of space we must abort.
     219$
     220$ we choose the second method since it is simpler and more efficient.
     221$ experience will allow us to make good estimates. furthermore if we
     222$ over estimate the size of the constants area we can always garbage
     223$ collect the extra space.
     224$
     225$ there are several standard pointers into the heap:
     226$
     227$ t:         points to top of stack
     228$ h:         points to next free word of heap
     229$ h_org:     points to first word of heap proper
     230$ sym_org:   points to first word of the symbol table
     231$ sym_end:   points to last word of symbol table
     232$
     233$ in addition we keep a pointer to the next free word of the
     234$ constants area:
     235
     236      size h_const(ps);
     237
     238      +* get_const(n, p)  =   $ get n words in constants area
     239          p = h_const;
     240          h_const = h_const + n;
     241          if (h_const > h_org) call overfl('constants area');
     242          **
     243
     244      +* get_symtab(n)  =     $ get n symbol table entries
     245          sym_lim = sym_lim - n;
     246          if (sym_lim < sym_org) call overfl('run-time symbol table');
     247          **
     248
     249      +* get_code(n, p)  =    $ allocate storage for code
     250          if asm_flag then
     251              if codep ^= 0 & codep + inst_nw ^= h then
     252                  call abort('compiler error - please report');
     253              end if;
     254              get_heap(n, p);
     255          else
     256              get_const(n, p);
     257          end if;
     258          **
smfb  90
smfb  91
smfb  92      size h_names1(ps);      $ end of last names string block
smfb  93      size h_names2(ps);      $ start of next block
     259
     260
     261$ treatment of built in procedures
     262$
     263$ certain language primitives such as read and print are expressed
     264$ as procedure calls, both at the source level and at the q1 level.
     265$ during code generation calls to built in procedures are special
     266$ cased to produce more efficient code.
     267$
     268$ each built in procedure xxx has a corresponding q2 opcode
     269$ q2_xxx which calls the corresponding procedure in the run time
     270$ library.
     271$
     272$ for the moment we pass arguments to built in procedures the same
     273$ way we pass arguments to procedures written in setl, i.e. by
     274$ a series of stack pushes and pops.
     275$
     276$ in the near future we will improve the calling sequence for
     277$ non-recursive procedures so that the argin and argout assignments
     278$ are made directly between the argument and the parameter, without
     279$ using the stack. as a side effect, this will improve argument
     280$ passage for built in procedures.
     281$
     282$ eventually we will add more special casing so that the
     283$ instructions for built in procedure calls contain the arguments
     284$ directly.
     285$
     286$ the array bip_op maps the names of built in procedures into
     287$ the corresponding q2 opcode.
     288
     289      +*  bip_op(nam)  = a_bip_op(nam - sym_bip_min + 1)  **
     290
     291      size a_bip_op(ps);
     292      dims a_bip_op(sym_bip_max - sym_bip_min + 1);
     293
     294      data bip_op(sym_open)        =  q2_open:    $ open
     295           bip_op(sym_close)       =  q2_close:   $ close
     296           bip_op(sym_print)       =  q2_print:   $ print
     297           bip_op(sym_read)        =  q2_read:    $ read
     298           bip_op(sym_printa)      =  q2_printa:  $ printa
     299           bip_op(sym_reada)       =  q2_reada:   $ reada
     300           bip_op(sym_get)         =  q2_get:     $ get
     301           bip_op(sym_put)         =  q2_put:     $ put
     302           bip_op(sym_getb)        =  q2_getb:    $ getb
     303           bip_op(sym_putb)        =  q2_putb:    $ putb
     304           bip_op(sym_getk)        =  q2_getk:    $ getk
     305           bip_op(sym_putk)        =  q2_putk:    $ putk
     306           bip_op(sym_getf)        =  q2_getf:    $ getf
     307           bip_op(sym_callf)       =  q2_callf:   $ callf
     308           bip_op(sym_putf)        =  q2_putf:    $ putf
     309           bip_op(sym_rewind)      =  q2_rewind:  $ rewind
     310           bip_op(sym_eof)         =  q2_eof:     $ .eof
     311           bip_op(sym_eject)       =  q2_eject:   $ eject
     312           bip_op(sym_title)       =  q2_titl:    $ title
     313           bip_op(sym_getipp)      =  q2_getipp:  $ getipp
     314           bip_op(sym_getspp)      =  q2_getspp:  $ getspp
     315           bip_op(sym_getem)       =  q2_getem:   $ getem
     316           bip_op(sym_setem)       =  q2_setem:   $ setem
     317           bip_op(sym_host)        =  q2_host:    $ host
     318           bip_op(sym_span)        =  q2_span:    $ span
     319           bip_op(sym_break)       =  q2_break:   $ break
     320           bip_op(sym_match)       =  q2_match:   $ match
     321           bip_op(sym_lpad)        =  q2_lpad:    $ lpad
     322           bip_op(sym_len)         =  q2_len:     $ len
     323           bip_op(sym_any)         =  q2_any:     $ any
     324           bip_op(sym_notany)      =  q2_notany:  $ notany
     325           bip_op(sym_rspan)       =  q2_rspan:   $ rspan
     326           bip_op(sym_rbreak)      =  q2_rbreak:  $ rbreak
     327           bip_op(sym_rmatch)      =  q2_rmatch:  $ rmatch
     328           bip_op(sym_rpad)        =  q2_rpad:    $ rpad
     329           bip_op(sym_rlen)        =  q2_rlen:    $ rlen
     330           bip_op(sym_rany)        =  q2_rany:    $ rany
     331           bip_op(sym_rnotany)     =  q2_rnotany; $ rnotany
     332
     333
     334
     335
     336
     337$ attributes of current instruction
     338
     339      size curmemb(ps);       $ name of current member
     340      size currout(ps);       $ name of current routine
     341      size curunit(ps);       $ name of current scope
     342
     343      size unit_type(ps);     $ type of current unit
     344
     345$ the codes for unit_type are:
     346
     347 .=zzyorg z
     348
     349      defc(unit_sys)          $ system scope
     350      defc(unit_lib)          $ library
     351      defc(unit_dir)          $ directory
     352      defc(unit_prog)         $ program
     353      defc(unit_mod)          $ module
     354      defc(unit_proc)         $ procedure
     355      defc(unit_end)          $ end of compilation
     356
     357      +*  unit_min  =  unit_sys   **
     358      +*  unit_max  =  unit_end   **
     359
     360
     361$ variables are divided into the following storage classes:
     362
     363 .=zzyorg z
     364
stra  11      defc(scl_untyped)       $ constants and untyped values
stra  12      defc(scl_param)         $ formal parameters
stra  13      defc(scl_static)        $ static typed variables and bases
stra  14      defc(scl_stacked)       $ stacked typed variables
     369
stra  15      +*  scl_min  =  scl_untyped  **  $ minimum class
stra  16      +*  scl_max  =  scl_stacked  **  $ maximum class
     372
     373
     374$ there are two maps on storage classes:
     375
     376$ blocklen: gives the length of each block for the current scope
     377$ blockorg: gives the origin of each block for the current scope
     378
     379      size blocklen(ps);
stra  17      dims blocklen(scl_max);
     381
     382      size blockorg(ps);
stra  18      dims blockorg(scl_max);
     384
     385
     386$ we keep three statement counters:
     387$
     388$ cstmt_count:   the cummulative statement count
     389$ ustmt_count:   the cstmt_count at the start of the current unit
     390$ estmt_count:   the cstmt_count of the q1_entry instruction.  note that
     391$                this count is only set for procedure scopes.
     392$
     393$ the current statement number is equal to cstmt_count - ustmt_count + 1
     394
     395      +* stmt_count  =  (cstmt_count - ustmt_count + 1)  **
     396
     397      size cstmt_count(ps);   data cstmt_count = 0;
     398      size ustmt_count(ps);   data ustmt_count = 0;
     399      size estmt_count(ps);   data estmt_count = 0;
     400$
     401$ in addition, we keep a count of the number of q2 statements generated,
     402$ for statistical purposes.
     403$
     404      size stmt_tot(ps);      $ total number of statements
     405      data stmt_tot = 0;
     406
     407      size error_count(ps);   $ error count
     408      data error_count = 0;
     409
     410      size eof_flag(1);       $ indicates eof on q1 file
     411      data eof_flag = no;
smfa  20
smfa  21
smfa  22      size rnames(ps);        $ pointer to run-time names tuple
smfa  23
     412
     413
     414      size prev(ps);          $ points to previous instruction
     415      size now(ps);           $ points to curent instruction
     416
     417      +*  op  = opcode(now)  **  $ current opcode
     418      +*  a1  = arg1(now)    **  $ current arg1
     419      +*  a2  = arg2(now)    **  $ current arg2
     420      +*  a3  = arg3(now)    **  $ current arg3
     421      +*  a4  = arg4(now)    **  $ current arg4
     422
     423      +*  fm1 =  form(a1)    **  $ their types
     424      +*  fm2 =  form(a2)    **
     425      +*  fm3 =  form(a3)    **
     426      +*  fm4 =  form(a4)    **
     427
     428      size addr_a1(ps),  $ their run time addresses
     429           addr_a2(ps),
     430           addr_a3(ps),
     431           addr_a4(ps);
     432
     433$ the following macros give the addresses of the standard
     434$ temporaries used for copies and conversions.
     435
     436      +*  addr_t1  =  address(sym_t1_)  **
     437      +*  addr_t2  =  address(sym_t2_)  **
     438      +*  addr_t3  =  address(sym_t3_)  **
     439      +*  addr_t4  =  address(sym_t4_)  **
     440
     441
     442
     443$ utility macros
     444
     445      +* symtype(nam)  =      $ type of symbol
     446          ft_type(form(nam))
     447          **
     448
     449      +* symval(nam)  =       $ first word of value
     450          val(vptr(nam))
     451          **
     452
     453      +* get_addr(addr, nam)  =  $ get address of symbol
     454          size zzza(ps);
     455
     456          zzza = nam;
     457          if (alias(zzza) ^= 0) zzza = alias(zzza);
     458
     459          addr = 0;
     460          if (zzza ^= 0) addr = address(zzza);
     461          **
     462
     463
     464      +*  code_loop  =  $ standard loop over q1 code
     465          size zzza(ps);
     466
     467
     468          do zzza = blocktab_org+1 to blocktabp;
     469
     470              prev = 0;
     471              now  = b_first(zzza);
     472
     473              while now ^= 0;
     474          **
     475
     476
     477      +*  cont_loop  =  $ continue
     478          go to nxt_lab;
     479          **
     480
     481
     482      +*  quit_loop  =  $ quit
     483          quit do;
     484          **
     485
     486
     487      +*  end_loop  =    $ end
     488              /nxt_lab/
     489                  prev = now;
     490                  now  = next(now);
     491              end while;
     492          end do;
     493          **
     494
     495
     496      +*  lines_max  =  $ no. of lines between headings on dumps
     497          20
     498          **
     499
     500
     501$ code for backtracking
     502$ ---------------------
     503$
     504$ the opcodes for backtracking fall into two categories:
     505$
     506$ 1. opcodes which save environments
     507$ 2. opcodes which restore environments
     508$
     509$ the instructions in group (1) build 'environment blocks' on
     510$ the stack; the instructions in group (2) pop them. each
     511$ environment block contains a pointer to the appropriate
     512$ restore instruction.
     513$
     514$ the block types and their appropriate instructions are:
     515$
     516$    environment type         save instruction    restore instruction
     517$    ----------------         ----------------    -------------------
     518$
     519$     entry block              q2_entry             q2_dexit
     520$     exit block               q2_exit              q2_undo
     521$     ok block                 q2_ok                q2_fail2
     522$
     523$ each routine contains a single dexit, undo, and fail2 instruction.
     524$ these instructions are located at the beginning of the procedure.
     525$ thus a procedure prologue looks like:
     526$
     527$    entry instruction
     528$    branch to body
     529$
     530$    dexit, undo, and fail2 instructions
     531$
     532$    body
     533$
     534$ we keep global pointers to the undo and fail2 instructions since
     535$ they are needed as arguments to the exit and fail instructions
     536$ respectively.
     537
     538      size undo_addr(ps),
     539           fail2_addr(ps);
     540
     541
     542
     543
     544
     545$ o p t a b
     546$ ---------
     547$
     548$ the array 'optab' gives information on q1 opcodes. its fields are:
     549$
     550$ class:       code cl_xxx giving class of instruction
     551$ std_op:      standard q2 opcode
     552$ if_op:       maps predicate into branch on true
     553$ ifn_op:      maps predicate into branch on false
     554$ is_pre:      see below
     555$
     556$ when we have a code  pattern such as:
     557$
     558$    t := b op c;
     559$    a := t;
     560$
     561$ we have two choices:
     562$
     563$ 1. give t a type which is a function of op, b, and c.
     564$    then convert on the assignment if necessary
     565$
     566$ 2. give t the type of a. if necessary convert b and c before
     567$    applying 'op'.
     568$
     569$ the choice we make is a function of op. the map is_pre(op)
     570$ is true for opcodes where we use case (2).
     571
     572      size optab(32);
     573      dims optab(q1_maximum);
     574
     575      +*  class(i)     =  .f. 01, 06, optab(i)  **
     576      +*  ops_ovar(i)  =  .f. 07, 01, optab(i)  **
     577      +*  is_pre(i)    =  .f. 08, 01, optab(i)  **
     578      +*  if_op(i)     =  .f. 09, 07, optab(i)  **
     579      +*  ifn_op(i)    =  .f. 16, 07, optab(i)  **
     580      +*  std_op(i)    =  .f. 23, 10, optab(i)  **
     581
     582
     583      data
     584
     585      +* s(op, cl, std, if, ifn, ovar, pre) =
     586          optab(op) =   std  * 4b'00400000'
     587                      + ifn  * 4b'00008000'
     588                      + if   * 4b'00000100'
     589                      + pre  * 4b'00000080'
     590                      + ovar * 4b'00000040'
     591                      + cl   * 4b'00000001'
     592          **
     593
     594$       op        class     std_op    if_op     ifn_op    ovar pre
     595
     596      s(q1_in,    cl_pred1, q2_in,    q1_ifin,  q1_ifnin, yes, no ):
     597      s(q1_notin, cl_pred1, q2_nin,   q1_ifnin, q1_ifin,  yes, no ):
     598      s(q1_incs,  cl_pred2, q2_incs,  q1_ifinc, q1_ifsub, yes, no ):
     599      s(q1_lt,    cl_pred2, q2_lt,    q1_iflt,  q1_ifge,  yes, no ):
     600      s(q1_ge,    cl_pred2, q2_ge,    q1_ifge,  q1_iflt,  yes, no ):
smfb  94      s(q1_pos,   cl_pred2, 0,              0,        0,  yes, no ):
     601      s(q1_eq,    cl_pred2, q2_eq,    q1_ifeq,  q1_ifne,  yes, no ):
     602      s(q1_ne,    cl_pred2, q2_ne,    q1_ifne,  q1_ifeq,  yes, no ):
     603      s(q1_with,  cl_with,  q2_with,  0,        0,        yes, yes):
     604      s(q1_less,  cl_with,  q2_less,  0,        0,        yes, no ):
     605      s(q1_lessf, cl_lessf, q2_lessf, 0,        0,        yes, no ):
     606      s(q1_npow,  cl_uset,  q2_npow,  0,        0,        yes, no ):
     607      s(q1_min,   cl_min,   q2_min,   0,        0,        yes, no ):
     608      s(q1_max,   cl_min,   q2_max,   0,        0,        yes, no ):
     609      s(q1_add,   cl_bin,   q2_add,   0,        0,        yes, yes):
     610      s(q1_sub,   cl_bin,   q2_sub,   0,        0,        yes, yes):
     611      s(q1_mult,  cl_bin,   q2_mult,  0,        0,        yes, yes):
     612      s(q1_slash, cl_bin,   q2_slash, 0,        0,        yes, yes):
     613      s(q1_div,   cl_bin,   q2_div,   0,        0,        yes, yes):
     614      s(q1_mod,   cl_bin,   q2_mod,   0,        0,        yes, yes):
     615      s(q1_atan2, cl_real,  q2_atan2, 0,        0,        yes, no ):
     616      s(q1_exp,   cl_bin,   q2_exp,   0,        0,        yes, no ):
     617
     618$       op          class       std_op      if_op  ifn_op ovar pre
     619
     620      s(q1_not,     cl_not,     q2_not,     0,     0,     yes, no ):
     621      s(q1_even,    cl_bool,    q2_even,    0,     0,     yes, no ):
     622      s(q1_odd,     cl_bool,    q2_odd,     0,     0,     yes, no ):
     623      s(q1_isint,   cl_bool,    q2_isint,   0,     0,     yes, no ):
     624      s(q1_isreal,  cl_bool,    q2_isreal,  0,     0,     yes, no ):
     625      s(q1_isstr,   cl_bool,    q2_isstr,   0,     0,     yes, no ):
     626      s(q1_isbool,  cl_bool,    q2_isbool,  0,     0,     yes, no ):
     627      s(q1_isatom,  cl_bool,    q2_isatom,  0,     0,     yes, no ):
     628      s(q1_istup,   cl_bool,    q2_istup,   0,     0,     yes, no ):
     629      s(q1_isset,   cl_bool,    q2_isset,   0,     0,     yes, no ):
     630      s(q1_ismap,   cl_bool,    q2_ismap,   0,     0,     yes, no ):
     631      s(q1_arb,     cl_arb,     q2_arb,     0,     0,     yes, no ):
     632      s(q1_dom,     cl_st2,     q2_domain,  0,     0,     yes, no ):
     633      s(q1_range,   cl_st2,     q2_range,   0,     0,     yes, no ):
     634      s(q1_pow,     cl_uset,    q2_pow,     0,     0,     yes, no ):
     635      s(q1_nelt,    cl_nelt,    q2_nelt,    0,     0,     yes, no ):
     636      s(q1_abs,     cl_umin,    q2_abs,     0,     0,     yes, no ):
     637      s(q1_char,    cl_str,     q2_char,    0,     0,     yes, no ):
     638      s(q1_umin,    cl_umin,    q2_umin,    0,     0,     yes, no ):
     639      s(q1_ceil,    cl_int,     q2_ceil,    0,     0,     yes, no ):
     640      s(q1_floor,   cl_int,     q2_floor,   0,     0,     yes, no ):
     641      s(q1_fix,     cl_int,     q2_fix,     0,     0,     yes, no ):
     642      s(q1_float,   cl_real,    q2_float,   0,     0,     yes, no ):
     643      s(q1_sin,     cl_real,    q2_sin,     0,     0,     yes, no ):
     644      s(q1_cos,     cl_real,    q2_cos,     0,     0,     yes, no ):
     645      s(q1_tan,     cl_real,    q2_tan,     0,     0,     yes, no ):
     646      s(q1_arcsin,  cl_real,    q2_arcsin,  0,     0,     yes, no ):
     647      s(q1_arccos,  cl_real,    q2_arccos,  0,     0,     yes, no ):
     648      s(q1_arctan,  cl_real,    q2_arctan,  0,     0,     yes, no ):
     649      s(q1_tanh,    cl_real,    q2_tanh,    0,     0,     yes, no ):
     650      s(q1_expf,    cl_real,    q2_expf,    0,     0,     yes, no ):
     651      s(q1_log,     cl_real,    q2_log,     0,     0,     yes, no ):
     652      s(q1_sqrt,    cl_real,    q2_sqrt,    0,     0,     yes, no ):
     653      s(q1_rand,    cl_rand,    q2_rand,    0,     0,     yes, no ):
     654      s(q1_sign,    cl_int,     q2_sign,    0,     0,     yes, no ):
     655      s(q1_type,    cl_str,     q2_type,    0,     0,     yes, no ):
     656      s(q1_str,     cl_str,     q2_str,     0,     0,     yes, no ):
     657      s(q1_val,     cl_int,     q2_val,     0,     0,     yes, no ):
     658
     659      s(q1_newat,   cl_newat,   q2_newat1,  0,     0,     yes, yes):
     660      s(q1_time,    cl_int,     q2_time,    0,     0,     yes, no ):
     661      s(q1_date,    cl_str,     q2_date,    0,     0,     yes, no ):
     662      s(q1_na,      cl_int,     q2_na,      0,     0,     yes, no ):
     663
     664      s(q1_set,     cl_st,      0,          0,     0,     yes, yes):
     665      s(q1_set1,    cl_st1,     0,          0,     0,     yes, no ):
     666      s(q1_tup,     cl_st,      0,          0,     0,     yes, yes):
     667      s(q1_tup1,    cl_st1,     0,          0,     0,     yes, no ):
     668
     669      s(q1_from,    cl_from,    q2_from,    0,     0,     yes, no ):
     670      s(q1_fromb,   cl_from,    q2_fromb,   0,     0,     yes, no ):
     671      s(q1_frome,   cl_from,    q2_frome,   0,     0,     yes, no ):
     672
     673      s(q1_next,    cl_next,    q2_next,    0,     0,     yes, no ):
     674      s(q1_nextd,   cl_nextd,   q2_nextd,   0,     0,     yes, no ):
     675      s(q1_inext,   cl_next,    q2_inext,   0,     0,     yes, no ):
     676      s(q1_inextd,  cl_nextd,   q2_inextd,  0,     0,     yes, no ):
     677
     678      s(q1_of,      cl_of,      q2_of,      0,     0,     yes, no ):
     679      s(q1_ofa,     cl_ofa,     q2_ofa,     0,     0,     yes, no ):
     680      s(q1_end,     cl_subst,   q2_end,     0,     0,     yes, no ):
     681      s(q1_subst,   cl_subst,   q2_subst,   0,     0,     yes, no ):
     682
     683      s(q1_sof,     cl_sof,     q2_sof,     0,     0,     yes, no ):
     684      s(q1_sofa,    cl_sofa,    q2_sofa,    0,     0,     yes, no ):
     685      s(q1_send,    cl_ssubst,  q2_send,    0,     0,     yes, no ):
     686      s(q1_ssubst,  cl_ssubst,  q2_ssubst,  0,     0,     yes, no ):
     687
     688      s(q1_asn,     cl_asn,     q2_asn,     0,     0,     yes, no ):
     689      s(q1_argin,   cl_argin,   q2_push1,   0,     0,     no,  yes):
     690      s(q1_argout,  cl_argout,  q2_pop1,    0,     0,     yes, no ):
     691      s(q1_push,    cl_push,    q2_push1,   0,     0,     no,  no ):
     692      s(q1_free,    cl_free,    q2_free,    0,     0,     no,  no ):
     693
     694      s(q1_call,    cl_call,    q2_call,    0,     0,     no,  no ):
     695      s(q1_goto,    cl_goto,    q2_goto,    0,     0,     no,  no ):
     696      s(q1_if,      cl_ifgo,    0,          0,     0,     no,  no ):
     697      s(q1_ifnot,   cl_ifgo,    0,          0,     0,     no,  no ):
smfb  95      s(q1_bif,     cl_ifgo,    0,          0,     0,     no,  no ):
smfb  96      s(q1_bifnot,  cl_ifgo,    0,          0,     0,     no,  no ):
     698      s(q1_case,    cl_case,    q2_caseusm, 0,     0,     no,  no ):
     699      s(q1_stop,    cl_simp,    q2_stop,    0,     0,     no,  no ):
     700
     701      s(q1_entry,   cl_entry,   0,          0,     0,     no,  no ):
     702      s(q1_exit,    cl_exit,    0,          0,     0,     no,  no ):
     703
     704      s(q1_ok,      cl_ok,      q2_ok,      0,     0,     no,  no ):
     705      s(q1_lev,     cl_int,     q2_lev,     0,     0,     no,  no ):
     706      s(q1_fail,    cl_fail,    q2_fail1,   0,     0,     no,  no ):
     707      s(q1_succeed, cl_succeed, q2_succeed, 0,     0,     no,  no ):
     708
     709      s(q1_asrt,    cl_asrt,    q2_asrt,    0,     0,     no,  no ):
smfb  97      s(q1_ifasrt,  cl_asrt,    q2_ifasrt,  0,     0,     no,  no ):
     710      s(q1_stmt,    cl_stmt,    q2_stmt,    0,     0,     no,  no ):
     711      s(q1_label,   cl_lab,     q2_lab,     0,     0,     no,  no ):
     712      s(q1_tag,     cl_lab,     q2_tag,     0,     0,     no,  no ):
     713      s(q1_debug,   cl_debug,   0,          0,     0,     no,  no ):
     714      s(q1_trace,   cl_debug,   0,          0,     0,     no,  no ):
     715      s(q1_notrace, cl_debug,   0,          0,     0,     no,  no ):
     716      s(q1_error,   cl_simp,    q2_error,   0,     0,     no,  no ):
     717      s(q1_noop,    cl_noop,    0,          0,     0,     no,  no ):
     718
     719      s(q1_ifeq,    cl_ifgo1,   q2_goeq,    0,     0,     no,  no ):
     720      s(q1_ifne,    cl_ifgo1,   q2_gone,    0,     0,     no,  no ):
     721      s(q1_ifge,    cl_ifgo1,   q2_goge,    0,     0,     no,  no ):
     722      s(q1_iflt,    cl_ifgo1,   q2_golt,    0,     0,     no,  no ):
     723      s(q1_ifin,    cl_ifgo1,   q2_goin,    0,     0,     no,  no ):
     724      s(q1_ifnin,   cl_ifgo1,   q2_gonin,   0,     0,     no,  no ):
     725      s(q1_ifinc,   cl_ifgo1,   q2_goincs,  0,     0,     no,  no ):
     726      s(q1_ifsub,   cl_ifgo1,   q2_gonincs, 0,     0,     no,  no );
     727
     728      macdrop(s)
     729
     730
     731$ special casing
     732$ --------------
     733$
     734$ one of the main tasks of the 'codegen' phase is to perform special
     735$ casing of each instruction based on the types of its inputs.
     736$
     737$ each q1 primitive has one 'crucial' argument whose type is
     738$ particularly useful in special casing the instruction. for example,
     739$ when we special case 'a1(a2) := a3', we are most interested in
     740$ the type of a1.
     741$
     742$ mapping a q1 opcode into the proper q2 opcode is done in three
     743$ steps:
     744$
     745$ 1. find the 'crucial' argument and see if the other arguments
     746$    are compatible with its type.
     747$
     748$ 2. if the types are compatible, then look up the appropriate
     749$    opcode in 'spec_op'. spec_op is a map from pairs [q1 opcode,
     750$    form of crucial argument] to q2 opocdes.
     751$
     752$    if spec_op indicates zero, then there is no special case
     753$    opcode available, and we proceed to step 3.
     754$
     755$ 3. if the argument types are incompatible or there is no
     756$    special case, then we will use the standard q2 opcode,
     757$    which is given by std_op(q1 opcode).
     758
     759
     760      +*  opsz =    $ size of q1 opcode - should divide word size
suna  15 .+r32    16
suna  16 .+r36    12
     761 .+s66    10
     767          **
     768
     769      +*  spec_op(op, form)  =
     770          .f. 1 + ft_type(form) * opsz, opsz, a_spec_op(op)
     771          **
     772
     773      size a_spec_op((f_max+1) * opsz);
     774      dims a_spec_op(q1_maximum);
     775      data a_spec_op = 0(q1_maximum);
     776
     777
     778
     779$ in order to special case 'of' and 'sof' operations on maps we must
     780$ look at both the ft_type and ft_mapc fields of the map. this is done
     781$ by the table 'of_op'.
     782
     783      +*  of_op(op, tp, mapc) =
     784          .f. 1 + (tp * ft_max + mapc-1) * opsz, opsz,
     785              a_of_op(op - q1_of + 1)
     786          **
     787
     788      size a_of_op((f_max + 1) * ft_max * opsz);
     789      dims a_of_op(q1_sofa - q1_of + 1);
     790      data a_of_op = 0(q1_sofa - q1_of + 1);
     791
     792$ the table 'share_op' maps retrivel operations which do not
     793$ set share bits into those which do.
     794
     795      +*  share_op(op)  =
     796          a_share_op(op - q2_of + 1)
     797          **
     798
     799      size a_share_op(ps);
     800      dims a_share_op(q2_ofarmm - q2_of + 1);
     801      data a_share_op = 0(q2_ofarmm - q2_of + 1);
     802
     803$ there are various special opcodes for testing a variable for
     804$ equality with a system constant. the table 'eq_op' gives
     805$ the special opcodes for each system constant. it has the
     806$ following fields:
     807
     808$ eqop:   gives special case for q1_eq
     809$ neop:   gives special case for q1_ne
     810$ ifeqop: gives special case for q1_ifeq
     811$ ifneop: gives special case for q1_ifne
     812
     813      size eq_op(4 * opsz);
     814      dims eq_op(sym_maximum);
     815      data eq_op = 0(sym_maximum);
     816
     817      +*  eqop(i)     =  .f. 1 + 0*opsz, opsz, eq_op(i)  **
     818      +*  neop(i)     =  .f. 1 + 1*opsz, opsz, eq_op(i)  **
     819      +*  ifeq_op(i)  =  .f. 1 + 2*opsz, opsz, eq_op(i)  **
     820      +*  ifne_op(i)  =  .f. 1 + 3*opsz, opsz, eq_op(i)  **
     821
     822
     823
     824$ typetab
     825$ -------
     826
     827$ the array typetab maps ft_type codes into type codes and htype
     828$ codes. its fields are:
     829
     830$ tmap:    maps code f_xxx into code t_xxx
     831$ htmap:   maps code f_xxx into code h_xxx
     832
     833      +*  tmap(i)  =  .f. 01, 16, typetab(i)  **
     834      +*  htmap(i) =  .f. 17, 16, typetab(i)  **
     835
     836      defzero(typetab, a_typetab);
     837
     838      size a_typetab(32);
     839      dims a_typetab(f_max+1);
     840      data
     841
     842      +* s(fm, tp, ht)  =
     843          typetab(fm) = ht * 4b'00010000'  +  tp
     844          **
     845
     846      s(f_gen,     t_oint,      0         ):
     847      s(f_sint,    t_oint,      0         ):
     848      s(f_sstring, t_ostring,   0         ):
     849      s(f_atom,    t_oatom,     0         ):
     850      s(f_latom,   t_olatom,    h_latom   ):
     851      s(f_elmt,    t_oelmt,     0         ):
     852      s(f_int,     t_olint,     h_lint    ):
     853      s(f_string,  t_oistring,  h_lstring ):
     854      s(f_real,    t_oreal,     h_real    ):
     855      s(f_ituple,  t_ostuple,   h_ituple  ):
     856      s(f_rtuple,  t_ostuple,   h_rtuple  ):
     857      s(f_ptuple,  t_ostuple,   h_ptuple  ):
     858      s(f_tuple,   t_otuple,    h_tuple   ):
     859      s(f_mtuple,  t_otuple,    h_tuple   ):
     860      s(f_uset,    t_oset,      h_uset    ):
     861      s(f_lset,    t_oset,      h_lset    ):
     862      s(f_rset,    t_oset,      h_rset    ):
     863      s(f_umap,    t_omap,      h_umap    ):
     864      s(f_lmap,    t_omap,      h_lmap    ):
     865      s(f_rmap,    t_omap,      h_rmap    ):
     866      s(f_lpmap,   t_omap,      h_lpmap   ):
     867      s(f_limap,   t_omap,      h_limap   ):
     868      s(f_lrmap,   t_omap,      h_lrmap   ):
     869      s(f_rpmap,   t_omap,      h_rpmap   ):
     870      s(f_rimap,   t_omap,      h_rimap   ):
     871      s(f_rrmap,   t_omap,      h_rrmap   ):
     872      s(f_base,    t_set,       h_base    ):
     873      s(f_pbase,   t_olatom,    h_latom   ):
     874      s(f_error,   t_oerror,    0         );
     875
     876      macdrop(s)
     877
     878
     879$ the following parameters are read from the control card:
     880
     881      size q1_title(.sds. filenamlen);    $ little q1 file
     882      size sq1_title(.sds. filenamlen);   $ setl q1 file
     883      size q2_title(.sds. filenamlen);    $ q2 file
     884      size term_title(.sds. filenamlen);  $ terminal file
     885
     886      size rem(ps);           $ run-time error mode
     887      size cel(ps);           $ code generator error limit
     888      size sym_lim(ps);       $ current extend of symbol table
     889      size ca_lim(ps);        $ dimension of constants area
     890      size asm_flag(1);       $ on if producing assembly code
     891      size sif_flag(1);       $ save intermediate files
     892      size tre_flag(1);       $ on if entry trace desired
     893      size et_flag(1);        $ on if error trace desired
     894      size q1cd_flag(1);      $ q1 code dumps after 'fixup'
     895      size q1sd_flag(1);      $ q1 symtab dumps after 'alloc'
     896      size q2cd_flag(1);      $ q2 code dumps after 'codegen'
     897      size q2sd_flag(1);      $ q2 storage dump after 'inienv2'
sunb  12      size lcp_flag(1);       $ listing control:  program parameters
sunb  13      size lcs_flag(1);       $ listing control:  program statistics
     898      size opt_flag(1);       $ on if global optimizer in use
smfb  98      size rpr_flag(ps);      $ on to generate conversion messages
     899      size stmt_flag(2);      $ on to generate q2 statement quadruples
     900
     901$ utility functions
     902
     903      size symsds(sds_sz);    $ returns symtab entry as sds
     904      size namesds(sds_sz);   $ returns names entry as sds
     905      size can_assign(1);     $ true if assignment is trivial
     906      size simp_type(ps);     $ result type of simple operation
     907      size bin_type(ps);      $ result type of binary op
     909      size elmt_type(ps);     $ element type
     910      size dom_type(ps);      $ domain type
     911      size im_type(ps);       $ image type
     912      size compn_typ(ps);     $ type of n-th component
     913      size rset_type(ps);     $ range set type
     914      size arg_type(ps);      $ argument type for procedure
     915
     916
     917$ i-o macros
     918$ ----------
     919
     920
     921$ file numbers
     922
     923 .=zzyorg z
     924
     925      defc(in_file)           $ input
     926      defc(out_file)          $ output
     927      defc(q1_file)           $ little q1 file
     928      defc(sq1_file)          $ setl q1 file
     929      defc(q2_file)           $ q2
     930
     931
     932      end nameset nscod;
     933
     934
     935
     936
     937
     938$ begin execution
     939
     940      call stlini;            $ initialise the q2 tables.
     941      call codini;            $ initialize
     942      call inienv1;           $ start building heap
     943
     944      while 1;
     945          call gettab;
     946          if (eof_flag) quit;
     947
     948          if (unit_type = unit_proc) call fixup;
     949          call alloc;
     950          if (unit_type = unit_proc) call codegen;
     951          call inienv2;
     952      end while;
     953
     954      call codtrm(0);         $ normal termination
     955
     956 .+s66 end subr start;
     957 .+r32 end prog stlcod;
     958 .+s10 end prog stlcod;
     959 .+s20 end prog stlcod;
     960
     961
     962 .+tr trace entry;            $ entry trace for code generator
     963
     964
       1 .=member codini
       2      subr codini;
       3
       4$ this routine is called to initialize the code generator.  there
       5$ are three types of initialization performed:
       6$
       7$ 1. read control card parameters
       8$ 2. open files
       9$ 3. initialize tables used for special casing.
      10
      11
      12      size ret(ps);           $ return code from dropsio and namesio
      13      size timestr(.sds. 30); $ current time
      14      size termh_flag(1);     $ print phase heading on terminal
      15
      16      runtime_flag = no;      $ indicates compile time
      17
      18      access q1vars;          $ access global q1 variables.
      19      access nscod;           $ access variables global to cod.
      20
      21
      22$ read control card options
      23
      24 .+s10.
      25      call getspp(q1_title,   'q1=q1/q1');        $ q1 file
      26      call getspp(sq1_title,  'sq1=/sq1');        $ setl q1 file
      27      call getspp(q2_title,   'q2=q2/q2');        $ q2 file
      28 ..s10
      29 .+s20.
      30      call getspp(q1_title,   'q1=q1/q1');        $ q1 file
      31      call getspp(sq1_title,  'sq1=/sq1');        $ setl q1 file
      32      call getspp(q2_title,   'q2=q2/q2');        $ q2 file
      33 ..s20
      34
      35
      36 .+s32.
      37      call getspp(q1_title,   'q1=q1.tmp/');      $ q1 file
      38      call getspp(sq1_title,  'sq1=/sq1.tmp');    $ setl q1 file
      39      call getspp(q2_title,   'q2=q2.tmp/');      $ q2 file
      40 ..s32
      41
      42 .+s37cms.
      43      call getspp(q1_title,   'q1=q1/q1');        $ q1 file
      44      call getspp(sq1_title,  'sq1=/sq1');        $ setl q1 file
      45      call getspp(q2_title,   'q2=q2/q2');        $ q2 file
      46 ..s37cms
      47 .+s37mts.
      48      call getspp(q1_title,   'q1=-setlq1/');     $ little q1 file
      49      call getspp(sq1_title,  'sq1=/-setlsq1');   $ setl q1 file
      50      call getspp(q2_title,   'q2=q2/q2');        $ q2 file
      51 ..s37mts
      52 .+s47.
      53      call getspp(q1_title,   'q1=q1/q1');        $ q1 file
      54      call getspp(sq1_title,  'sq1=/sq1');        $ setl q1 file
      55      call getspp(q2_title,   'q2=q2/q2');        $ q2 file
      56 ..s47
      57
      58 .+s66.
      59      call getspp(q1_title,   'q1=q1/q1');        $ q1 file
      60      call getspp(sq1_title,  'sq1=/sq1');        $ setl q1 file
      61      call getspp(q2_title,   'q2=q2/q2');        $ q2 file
      62 ..s66
suna  17
suna  18 .+s68.
suna  19      call getspp(q1_title,   'q1=setl.lq1/');    $ little q1 file
suna  20      call getspp(sq1_title,  'sq1=/setl.sq1');   $ setl q1 file
suna  21      call getspp(q2_title,   'q2=setl.q2/');     $ q2 file
suna  22 ..s68
      63
      64      call getipp(h_lim,      'h=0/0');     $ heap dimension
      65      call getipp(ca_lim,     'ca=0/0');    $ constant area dims
      66      call getipp(sym_lim,    'st=0/0');    $ symbol table dims
      67      call getipp(cel,        'cel=1000/1000'); $ cod error limit
      68      call getipp(rem,        'rem=2/2');   $ runtime error mode
      69      call getipp(opt_flag,   'opt=0/1');   $ global optimization
smfb  99      call getipp(rpr_flag,   'reprs=1/1'); $ conversion messages
      70      call getipp(stmt_flag,  'stmt=1/2');  $ q2_stmt quadruples
      71      call getipp(back_flag,  'back=0/1');  $ backtracking
      72      call getipp(asm_flag,   'asm=0/1');   $ produce assembly code
      73      call getipp(sif_flag,   'sif=0/1');   $ save q1 files
      74      call getipp(debug_flag, 'debug=0/1'); $ initialise debugger
      75      call getipp(termh_flag, 'termh=0/1'); $ print phase heading
asca   9 .+ascebc.
asca  10      call getipp(ascebc_flag,  'ascii=0/1');   $ebcdic-to-ascii conv
asca  11 ..ascebc
      76
      77      $ compiler debugging options
      78      call getipp(tre_flag,   'ctre=0/1');  $ little entry trace
      79      call getipp(q1cd_flag,  'cq1cd=0/1'); $ q1 code dumps
      80      call getipp(q1sd_flag,  'cq1sd=0/1'); $ q1 symtab dumps
      81      call getipp(q2cd_flag,  'cq2cd=0/1'); $ q2 code dumps
      82      call getipp(q2sd_flag,  'cq2sd=0/1'); $ q2 storage dumps
      83      call getipp(et_flag,    'et=0/1');    $ error trace
      84
      85      $ options for execution statistic package
      86      call getipp(st_lo,      'stlo=1/1');  $ first stmt for stats
      87      call getipp(st_hi,      'sthi=0/0');  $ last stmt for stats
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
      88
      89      st_no = st_hi - st_lo + 1;
      90
      91$ the code generator operates with the library error mode set to
      92$ err_off. library errors can only occur while we are initializing
      93$ the values of constants.  when an error occurs the library will
      94$ set the constant's value to omega. the code generator will check
      95$ for this and issue its own error message.
      96
      97      err_mode = err_off;
      98
      99      err_limit = cel;
     100
asca  12 .+ascebc.
asca  13      if (ascebc_flag) call aeinit;  $ initialise conversion tables
asca  14 ..ascebc
asca  15
     101      $ initialize little trace
     102      if tre_flag then
     103          monitor entry, limit = 10000;
     104      else
     105          monitor noentry;
     106      end if;
     107
     108      $ open all files
     109      if .len. sq1_title then
     110          file sq1_file   access = read,   title = sq1_title;
     111 .+s66    rewind sq1_file;
     112      else
     113          file q1_file    access = read,   title = q1_title;
     114 .+s66    rewind q1_file;
     115      end if;
     116      file q2_file    access = write,  title = q2_title;
     117 .+s66    rewind q2_file;
     118
     119      $ indicate which files can be deleted upon completion of cod
     120      if ^ sif_flag then
     121          if .len. sq1_title then
     122              call dropsio(sq1_file, ret);
     123          else
     124              call dropsio(q1_file,  ret);
     125          end if;
     126      end if;
     127
     128      $ initialize listing control
     129      call contlpr( 6, yes);  $ start paging
     130      call contlpr( 7, yes);  $ enable titling
     131      call lstime(timestr);   $ get current time
     132      call etitlr(0, 'cims.setl.' .cc. prog_level,  1, 0);
     133      call etitlr(0,                      timestr, 41, 0);
     134      call etitlr(0,                       'page', 71, 0);
     135      call contlpr( 8, 76);   $ set page number in column 76
     136      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
     137
sunb  36    if lcp_flag then  $ print phase heading
sunb  37      put ,'parameters for this compilation: ' ,skip
     140          ,skip ,'little q1 file: q1 = '       :q1_title   ,a ,'. '
     141                ,'setl q1 file: sq1 = '        :sq1_title  ,a ,'. '
     142          ,skip ,'q2 file: q2 = '              :q2_title   ,a ,'. '
     143                ,'save interm files: sif = '   :sif_flag   ,i ,'. '
     144          ,skip ,'codegen error limit: cel = ' :cel        ,i ,'. '
asca  16$$--            ,'codegen error file: term = ' :term_title ,a ,'. '
asca  17$$-- since term_title not initialized
     146          ,skip ,'global optimisation: opt = ' :opt_flag   ,i ,'. '
     147                ,'backtracking: back = '       :back_flag  ,i ,'. '
     148          ,skip ,'run-time error mode: rem = ' :rem        ,i ,'. '
     149                ,'assembly code: asm = '       :asm_flag   ,i ,'. '
     150          ,skip;
sunb  38    end if;
     151
     152      if termh_flag then
     153          $ the following line is printed on the terminal file only
     154          call contlpr(26, no);   call contlpr(27, yes);
     155          put ,'  start cims.setl.' ,prog_level :timestr ,a ,skip;
     156          call contlpr(26, yes);  call contlpr(27, no);
     157      end if;
     158
     159 .-sq1.
     160      if .len. sq1_title then
     161          call abort('setl q1 inteface not available');
     162      end if;
     163 ..sq1
     164
     165      call initab1;  $ initialize tables
     166      call initab2;
     167
     168
     169      end subr codini;
       1 .=member initab1
       2      subr initab1;
       3
       4$ this routine initializes various tables which handle special
       5$ casing.
       6
       7
       8      size j(ps);  $ loop index
       9
      10      access q1vars;          $ access global q1 variables.
      11      access nscod;           $ access variables global to cod.
      12
      13
      14$ some of the tables which we must initialize are maps on the standard
      15$ types f_xxx. before we can initialize these we must initialize the
      16$ standard formtab entries.  for now all that matters is that their
      17$ ft_type codes be correct.
      18
      19      do j = f_min to f_max;
      20          ft_type(j) = j;
      21      end do;
      22
      23
      24$ we begin by initializing spec_op.  this table maps pairs
      25$ [q1 opcode, type] into special q2 opcodes which are performed
      26$ inline.
      27
      28
      29      +* s(q1, tp, q2)  =     $ utility to initialize spec_op
      30          spec_op(q1, tp) = q2;
      31          **
      32
      33      s(q1_case,   f_tuple,     q2_caset  )
      34      s(q1_case,   f_lmap,      q2_caselsm)
      35      s(q1_case,   f_rmap,      q2_casersm)
      36      s(q1_case,   f_umap,      q2_caseusm)
      37$
      38$ if we plan to run the program with full error checking, then cannot
      39$ emit inline code.  if we leave the remaining entries of 'spec_op'
      40$ zero, then we achieve just that.  note that the q1_case cases above
      41$ represent an inline sequence which is generated under the exclusive
      42$ control of the compiler.  consequently no error should ever occur.
      43$
      44      if (rem = err_full) return;
      45
      46      s(q1_add,    f_sint,      q2_addi   )
      47      s(q1_add,    f_int,       q2_addli  )
      48      s(q1_add,    f_string,    q2_addstr )
      49      s(q1_add,    f_tuple,     q2_addtup )
      50      s(q1_add,    f_uset,      q2_unset  )
      51      s(q1_add,    f_lset,      q2_unlset )
      52      s(q1_add,    f_rset,      q2_unrset )
      53
      54      do j = f_umap to f_rpmap;
      55          s(q1_add, j, q2_union);
      56      end do;
      57
      58      s(q1_add,    f_uint,      q2_addui  )
      59      s(q1_add,    f_ureal,     q2_addur  )
      60
      61      s(q1_div,    f_sint,      q2_divi   )
      62$$--  due to mode propagation problem
      63$     s(q1_div,    f_int,       q2_divli  )
      64      s(q1_div,    f_uint,      q2_divui  )
      65
      66      do j = f_sint to f_latom;
      67          s(q1_eq, j, q2_eqv);
      68      end do;
      69
      70      do j = f_int to f_rpmap;
      71          s(q1_eq, j, q2_eq);
      72      end do;
      73
      74      s(q1_eq,     f_uint,      q2_eq1    )
      75      s(q1_eq,     f_ureal,     q2_eq1    )
      76
      77      do j = f_sint to f_latom;
      78          s(q1_ne, j, q2_nev);
      79      end do;
      80
      81      do j = f_int to f_rpmap;
      82          s(q1_ne, j, q2_ne);
      83      end do;
      84
      85      s(q1_ne,     f_uint,      q2_ne1    )
      86      s(q1_ne,     f_ureal,     q2_ne1    )
      87
      88
      89      s(q1_ge,     f_sint,      q2_gei    )
      90      s(q1_ge,     f_uint,      q2_geui   )
      91      s(q1_ge,     f_ureal,     q2_geur   )
      92
      93      s(q1_lt,     f_sint,      q2_lti    )
      94      s(q1_lt,     f_uint,      q2_ltui   )
      95      s(q1_lt,     f_ureal,     q2_ltur   )
      96
      97      s(q1_in,     f_uset,      q2_inu    )
      98      s(q1_in,     f_lset,      q2_inl    )
      99      s(q1_in,     f_rset,      q2_inr    )
     100
     101      do j = f_umap to f_rpmap;
     102          s(q1_in, j, q2_ins)
     103      end do;
     104
     105      s(q1_notin,  f_lset,      q2_ninl   )
     106      s(q1_notin,  f_rset,      q2_ninr   )
     107
     108      s(q1_less,   f_lset,      q2_lessls )
     109      s(q1_less,   f_rset,      q2_lessrs )
     110
     111      s(q1_lessf,  f_lmap,      q2_lessflm)
     112      s(q1_lessf,  f_limap,     q2_lessflm)
     113      s(q1_lessf,  f_lrmap,     q2_lessflm)
     114      s(q1_lessf,  f_rmap,      q2_lessfrm)
     115      s(q1_lessf,  f_rimap,     q2_lessfrm)
     116      s(q1_lessf,  f_rrmap,     q2_lessfrm)
     117
     118      s(q1_max,    f_sint,      q2_maxi   )
     119      s(q1_max,    f_uint,      q2_maxui  )
     120      s(q1_max,    f_ureal,     q2_maxur  )
     121
     122      s(q1_min,    f_sint,      q2_mini   )
     123      s(q1_min,    f_uint,      q2_minui  )
     124      s(q1_min,    f_ureal,     q2_minur  )
     125
     126      s(q1_mod,    f_sint,      q2_modi   )
     127      s(q1_mod,    f_int,       q2_modli  )
     128
     129      do j = f_uset to f_rpmap;
     130          s(q1_mod, j, q2_setmod);
     131      end do;
     132
     133      s(q1_mod,    f_uint,      q2_modui  )
     134
     135      s(q1_mult,   f_sint,      q2_multi  )
     136      s(q1_mult,   f_int,       q2_multli )
     137      s(q1_mult,   f_uset,      q2_inset  )
     138      s(q1_mult,   f_lset,      q2_inlset )
     139      s(q1_mult,   f_rset,      q2_inrset )
     140
     141      do j = f_umap to f_rpmap;
     142          s(q1_mult, j, q2_inter);
     143      end do;
     144
     145      s(q1_mult,   f_uint,      q2_multui )
     146      s(q1_mult,   f_ureal,     q2_multur )
     147
     148      s(q1_slash,  f_sint,      q2_slashi )
     149      s(q1_slash,  f_uint,      q2_slashui)
     150      s(q1_slash,  f_ureal,     q2_slashur)
     151
     152      s(q1_sub,    f_sint,      q2_subi   )
     153      s(q1_sub,    f_int,       q2_diffli )
     154      s(q1_sub,    f_uset,      q2_difset )
     155      s(q1_sub,    f_lset,      q2_diflset)
     156      s(q1_sub,    f_rset,      q2_difrset)
     157
     158      do j = f_umap to f_rpmap;
     159          s(q1_sub, j, q2_setdiff);
     160      end do;
     161
     162      s(q1_sub,    f_uint,      q2_subui  )
     163      s(q1_sub,    f_ureal,     q2_subur  )
     164
     165      s(q1_with,   f_uset,      q2_withus )
     166      s(q1_with,   f_lset,      q2_withls )
     167      s(q1_with,   f_rset,      q2_withrs )
     168      s(q1_with,   f_tuple,     q2_witht  )
     169      s(q1_with,   f_ituple,    q2_withut )
     170      s(q1_with,   f_rtuple,    q2_withut )
     171
     172      do j = f_umap to f_rpmap;
     173          s(q1_with, j, q2_withs);
     174      end do;
     175
     176
     177      s(q1_abs,    f_sint,      q2_absi   )
     178      s(q1_abs,    f_uint,      q2_absui  )
     179      s(q1_abs,    f_ureal,     q2_absur  )
     180
     181  /* must first assert that fixup does proper mode propagation
     182      s(q1_ceil,   f_ureal,     q2_ceilur )
     183      s(q1_floor,  f_ureal,     q2_floorur)
     184      s(q1_fix,    f_ureal,     q2_fixur  )
     185      s(q1_float,  f_uint,      q2_floatui)
     186  */
     187
     188      do j = f_uset to f_rpmap;
     189          s(q1_arb, j, q2_arbs);
     190      end do;
     191
     192      s(q1_arb,    f_ituple,    q2_arbut  )
     193      s(q1_arb,    f_rtuple,    q2_arbut  )
     194      s(q1_arb,    f_mtuple,    q2_arbt   )
     195      s(q1_arb,    f_tuple,     q2_arbt   )
     196
     197
     198      s(q1_nelt,   f_string,    q2_neltic )
strb   8      s(q1_nelt,   f_sstring,   q2_neltic )
     200
     201      do j = f_ituple to f_rpmap;
     202          s(q1_nelt, j, q2_neltst)
     203      end do;
     204
     205      s(q1_umin,   f_sint,      q2_umini  )
     206      s(q1_umin,   f_uint,      q2_uminui )
     207      s(q1_umin,   f_ureal,     q2_uminur )
     208
     209      s(q1_even,   f_sint,      q2_eveni  )
     210      s(q1_even,   f_uint,      q2_evenui )
     211
     212      s(q1_odd,    f_sint,      q2_oddi   )
     213      s(q1_odd,    f_uint,      q2_oddui  )
     214
     215      do j = f_umap to f_rpmap;
     216          s(q1_notin, j, q2_nins)
     217      end do;
     218
     219      s(q1_fromb,  f_ituple,    q2_frombt )
     220      s(q1_fromb,  f_rtuple,    q2_frombt )
     221      s(q1_fromb,  f_tuple,     q2_frombt )
     222
     223      s(q1_frome,  f_ituple,    q2_fromet )
     224      s(q1_frome,  f_rtuple,    q2_fromet )
     225      s(q1_frome,  f_tuple,     q2_fromet )
     226
     227      do j = f_uset to f_rpmap;
     228          s(q1_from, j, q2_froms);
     229      end do;
     230
     231      s(q1_next,   f_uset,      q2_nextus )
     232      s(q1_next,   f_lset,      q2_nextls )
     233      s(q1_next,   f_rset,      q2_nextrs )
     234
     235      s(q1_next,   f_ituple,    q2_nextut )
     236      s(q1_next,   f_rtuple,    q2_nextut )
     237      s(q1_next,   f_mtuple,    q2_nextt  )
     238      s(q1_next,   f_tuple,     q2_nextt  )
     239
     240      do j = f_umap to f_rpmap;
     241          s(q1_next, j, q2_nexts);
     242      end do;
     243
     244      do j = f_ituple to f_tuple;
     245          s(q1_inext, j, q2_inextt);
     246          s(q1_inextd, j, q2_inextd);
     247      end do;
     248
     249      do j = f_uset to f_rset;
     250          s(q1_inext, j, q2_inexts);
     251      end do;
     252
     253      do j = f_umap to f_rpmap;
     254          s(q1_inextd, j, q2_inextd);
     255      end do;
     256
strb   9      s(q1_of,     f_sstring,   q2_ofcl   )
     258      s(q1_of,     f_string,    q2_ofcl   )
     259      s(q1_of,     f_tuple,     q2_oft    )
     260      s(q1_of,     f_mtuple,    q2_oft    )
     261      s(q1_of,     f_rtuple,    q2_oft    )
     262      s(q1_of,     f_ituple,    q2_oft    )
     263      s(q1_of,     f_umap,      q2_ofum   )
     264      s(q1_of,     f_lmap,      q2_oflm   )
     265      s(q1_of,     f_rmap,      q2_ofrm   )
     266
strb  10      s(q1_sof,    f_sstring,   q2_sofcl  )
     268      s(q1_sof,    f_string,    q2_sofcl  )
     269      s(q1_sof,    f_tuple,     q2_soft   )
     270      s(q1_sof,    f_mtuple,    q2_soft   )
     271      s(q1_sof,    f_lmap,      q2_soflm  )
     272      s(q1_sof,    f_rmap,      q2_sofrm  )
     273
     274      do j = f_sint to f_latom;
     275          s(q1_ifeq, j, q2_goeqv);
     276      end do;
     277
     278      do j = f_int to f_rpmap;
     279          s(q1_ifeq, j, q2_goeq);
     280      end do;
     281
     282      s(q1_ifeq,   f_uint,      q2_goeq1  )
     283      s(q1_ifeq,   f_ureal,     q2_goeq1  )
     284
     285      s(q1_ifge,   f_sint,      q2_gogei  )
     286      s(q1_ifge,   f_uint,      q2_gogeui )
     287      s(q1_ifge,   f_ureal,     q2_gogeur )
     288
     289      s(q1_ifin,   f_uset,      q2_goinus )
     290      s(q1_ifin,   f_lset,      q2_goinl  )
     291      s(q1_ifin,   f_rset,      q2_goinr  )
     292
     293      do j = f_umap to f_rpmap;
     294          s(q1_ifin, j, q2_goins);
     295      end do;
     296
     297      s(q1_iflt,   f_sint,      q2_golti  )
     298      s(q1_iflt,   f_uint,      q2_goltui )
     299      s(q1_iflt,   f_ureal,     q2_goltur )
     300
     301      do j = f_sint to f_latom;
     302          s(q1_ifne, j, q2_gonev);
     303      end do;
     304
     305      do j = f_int to f_rpmap;
     306          s(q1_ifne, j, q2_gone);
     307      end do;
     308
     309      s(q1_ifne,   f_uint,      q2_gone1  )
     310      s(q1_ifne,   f_ureal,     q2_gone1  )
     311      s(q1_ifnin,  f_uset,      q2_goninus)
     312      s(q1_ifnin,  f_lset,      q2_goninl )
     313      s(q1_ifnin,  f_rset,      q2_goninr )
     314
     315      do j = f_umap to f_rpmap;
     316          s(q1_ifnin, j, q2_gonins);
     317      end do;
     318
     319      macdrop(s)
     320
     321
     322      end subr initab1;
       1 .=member initab2
       2      subr initab2;
       3
       4$ this routine continues the initiazation.
       5
       6
       7      size j(ps);  $ loop index
       8
       9      access q1vars;          $ access global q1 variables.
      10      access nscod;           $ access variables global to cod.
      11
      12
      13      +* s(q1, tp, mapc, q2)  =  $ utility to set 'of_op'
      14          of_op(q1, tp, mapc) = q2;
      15          **
      16
      17      s(q1_of,   f_umap,  ft_smap,  q2_ofusm  )
      18      s(q1_of,   f_lmap,  ft_smap,  q2_oflsm  )
      19      s(q1_of,   f_rmap,  ft_smap,  q2_ofrsm  )
      20      s(q1_of,   f_limap, ft_smap,  q2_oflsm  )
      21      s(q1_of,   f_lrmap, ft_smap,  q2_oflsm  )
      22      s(q1_of,   f_rimap, ft_smap,  q2_ofrsm  )
      23      s(q1_of,   f_rrmap, ft_smap,  q2_ofrsm  )
smfb 100
smfb 101      s(q1_of,   f_umap,  ft_map,   q2_ofum   )
smfb 102      s(q1_of,   f_lmap,  ft_map,   q2_oflm   )
smfb 103      s(q1_of,   f_rmap,  ft_map,   q2_ofrm   )
      24
      25      s(q1_ofa,  f_umap,  ft_mmap,  q2_ofaumm )
      26      s(q1_ofa,  f_lmap,  ft_mmap,  q2_ofalmm )
      27      s(q1_ofa,  f_rmap,  ft_mmap,  q2_ofarmm )
      28
      29      s(q1_sof,  f_lmap,  ft_smap,  q2_soflm  )
      30      s(q1_sof,  f_rmap,  ft_smap,  q2_sofrm  )
      31      s(q1_sof,  f_limap, ft_smap,  q2_soflm  )
      32      s(q1_sof,  f_lrmap, ft_smap,  q2_soflm  )
      33      s(q1_sof,  f_rimap, ft_smap,  q2_sofrm  )
      34      s(q1_sof,  f_rrmap, ft_smap,  q2_sofrm  )
      35
      36      $ start by assuming that all sets and maps use 'q2_sofas',
      37      $ then change the entries for local and remote mmaps.
      38      do j = f_uset to f_rpmap;
      39          s(q1_sofa, j, ft_smap, q2_sofas);
      40          s(q1_sofa, j, ft_map,  q2_sofas);
      41          s(q1_sofa, j, ft_mmap, q2_sofas);
      42      end do;
      43
      44      s(q1_sofa, f_lmap, ft_mmap, q2_sofalmm);
      45      s(q1_sofa, f_rmap, ft_mmap, q2_sofarmm);
      46
      47      macdrop(s)
      48
      49
      50      +* s(op1, op2)  =  share_op(op1) = op2;  **
      51
      52      s(q2_ofusm,   q2_ofusms )
      53      s(q2_oflsm,   q2_oflsms )
      54      s(q2_ofrsm,   q2_ofrsms )
      55
      56      s(q2_ofum,    q2_ofums  )
      57      s(q2_oflm,    q2_oflms  )
      58      s(q2_ofrm,    q2_ofrms  )
      59
      60      s(q2_ofaumm,  q2_ofaumms)
      61      s(q2_ofalmm,  q2_ofalmms)
      62      s(q2_ofarmm,  q2_ofarmms)
      63
      64      s(q2_oft,     q2_ofts   )
smfb 104      s(q2_oftok,   q2_oftoks )
      65
      66      macdrop(s)
      67
      68
      69      +*  s(sym, eq, ne, ifeq, ifne) =  $ macro to set eq_op
      70          eqop(sym)    = eq;
      71          neop(sym)    = ne;
      72          ifeq_op(sym) = ifeq;
      73          ifne_op(sym) = ifne;
      74          **
      75
      76      s(sym_zero,    q2_zr,      q2_nz,      q2_gozr,    q2_gonz   )
      77      s(sym_om,      q2_eqom,    q2_neom,    q2_goom,    q2_gonom  )
      78      s(sym_nullset, q2_eqnl,    q2_nenl,    q2_gonl,    q2_gonnl  )
      79      s(sym_nulltup, q2_eqnult,  q2_nenult,  q2_gonult,  q2_gonnult)
      80
      81      macdrop(s)
      82
      83
      84      end subr initab2;
       1 .=member gettab
       2      subr gettab;
       3
       4$ this routine reads in a page of q1.
       5
       6      size n(ps);             $ number of arguments
       7      size j(ps);             $ loop index
       8      size str(sds_sz);       $ unit name as sds
       9
      10      size getsbi(ws);        $ reads setl binary integer
      11      size getsbs(ps);        $ reads setl binary string
      12
      13      access q1vars;          $ access global q1 variables.
      14      access nscod;           $ access variables global to cod.
      15
      16
      17$
      18$ read the unit identifying record
      19$
      20      if .len. sq1_title then $ read from setl q1 file
      21          unit_type   = getsbi(0);
      22          curunit     = getsbs(0);   str = '';
      23          curunit     = getsbi(0);
      24          n           = getsbi(0);
      25          ustmt_count = getsbi(0);
      26          estmt_count = getsbi(0);
      27
      28      else
      29          read q1_file,
      30             unit_type, str, curunit, n, ustmt_count, estmt_count;
      31      end if;
      32$
      33$ set cstmt_count to the statement number at the beginning of the unit.
      34$
      35      cstmt_count = ustmt_count;
      36
      37      if unit_type = unit_end then
      38          eof_flag = yes;
      39          curmemb = 0;
      40          currout = 0;
      41          call setlab1;     $ process all labels which are still undefin
      42          return;
      43      end if;
      44
      45      if .len. sq1_title then call sgettb; else call lgettb; end if;
      46
      47      if et_flag then
smfa  28          put ,'compiling ' :symsds(curunit),a ,skip;
      49      end if;
      50
      51      if     ft_type(form(curunit)) = f_memb then curmemb = curunit;
      52      elseif ft_type(form(curunit)) = f_proc then currout = curunit;
      53      end if;
      54
      55$ clear all those symtab fields which are used differently by the
      56$ semantic pass.
      57
      58      do j = symtab_org+1 to symtabp;
      59          address(j)  = 0;
      60          labval(j)   = 0;
      61          is_seen(j)  = no;
      62          is_alias(j) = no;
      63          is_ldef(j)  = no;
      64          is_backpr(j) = no;
      65          is_casemap(j) = no;
      66      end do;
      67
      68$ clear all altrep fields. this is necessary since the altrep
      69$ field of a global symtab entry may point to a local one.
      70
      71      do j = 1 to symtabp;
      72          altrep(j) = 0;
      73      end do;
      74
      75$ clear the ft_samp fields of formtab.  this is necessary because
      76$ this field is used differently during the semantic pass.
      77
      78      do j = formtab_org + 1 to formtabp;
      79          ft_samp(j) = 0;
      80      end do;
      81
      82
      83      end subr gettab;
       1 .=member lgettb
       2      subr lgettb;
       3
       4$ this routine reads a page of q1 from the little q1 file.
       5
       6      access q1vars;          $ access global q1 variables.
       7      access nscod;           $ access variables global to cod.
       8
       9      +*  getr(ara, org, last, str) =  $ read array
      10          read q1_file, org, last;
      11          if (org < last) read q1_file, ara(org+1) to ara(last);
      12
      13          if (filestat(q1_file, error)) call abort('getr err '.cc.str);
      14          if (filestat(q1_file, end))   call abort('getr end '.cc.str);
      15          **
      16
      17      getr(mttab,    mttab_org,    mttabp,       'mttab');
      18      getr(formtab,  formtab_org,  formtabp,     'formtab');
      19      getr(names,    names_org,    namesp,       'names');
      20      getr(val,      val_org,      valp,         'val');
      21      getr(symtab,   symtab_org,   symtabp,      'symtab');
      22      getr(blocktab, blocktab_org, blocktabp,    'blocktab');
      23      getr(argtab,   argtab_org,   argtabp,      'argtab');
      24      getr(codetab,  codetab_org,  codetabp,     'codetab');
      25
      26      macdrop(getr)
      27
      28
      29      end subr lgettb;
       1 .=member sgettb
       2      subr sgettb;
       3
       4$ this routine reads a page of q1 from the setl q1 file.
       5
       6
       7 .-sq1    call abort('setl q1 inteface not available');
       8
       9 .+sq1.
      10
      11      size fm(ps);            $ form
      12      size hdr(ws);           $ binary header word
      13      size i(ps);             $ loop index
      14      size j(ps);             $ inner loop index
      15
      16      size ft_low_(ps);       $ ft_low field of form table
      17      size ft_lim_(ps);       $ ft_lim field of form table
      18      size ft_pos_(ps);       $ ft_pos field of form table
      19
      20      size getsbi(ws);        $ utilities to read setl binary values
      21      size getsbr(ws);
      22      size getsbb(1);
      23      size getsbs(ps);
      24
      25      access q1vars;          $ access global q1 variables.
      26      access nscod;           $ access variables global to cod.
      27
      28
      29$
      30$ form table
      31$
      32      $ get extend of current slice
      33      formtab_org = getsbi(0);  formtabp = getsbi(0);
      34
      35      $ compute current value for mttab_org and mttabp
      36      mttabp = 0;
      37
      38      do j = 0 to formtab_org;
      39          if ft_type(j) = f_mtuple ! ft_type(j) = f_proc then
      40              if ft_elmt(j) >= mttabp then
      41                  mttabp = ft_elmt(j) + ft_lim(j);
      42              end if;
      43          end if;
      44      end do;
      45
      46      mttab_org = mttabp;
      47
      48      $ read form table
      49      do i = formtab_org+1 to formtabp;
      50          formtab(i)    = 0;
      51
      52          read sq1_file, hdr;
      53
      54          if ^ (bh_typ_ hdr = bt_tuple & bh_val_ hdr = 0) then
      55              call ermsg(14, 0);
      56          end if;
      57
      58          ft_type(i)    = getsbi(0);
      59          ft_mapc(i)    = getsbi(0);
      60          ft_elmt(i)    = getsbi(0);
      61          ft_dom(i)     = getsbi(0);
      62          ft_im(i)      = getsbi(0);
      63          ft_imset(i)   = getsbi(0);
      64          ft_base(i)    = getsbi(0);
      65          ft_deref(i)   = getsbi(0);
      66          ft_low_       = getsbi(0);
      67          ft_lim_       = getsbi(0);
      68          ft_pos_       = getsbi(0);
      69          ft_hashok(i)  = getsbb(0);
      70          ft_neltok(i)  = getsbb(0);
      71
      72          $ account for field overlays in form table
      73          if is_floc(i) then
      74              ft_pos(i) = ft_pos_;
      75          else
      76              ft_low(i) = ft_low_;
      77              ft_lim(i) = ft_lim_;
      78          end if;
      79
      80          read sq1_file, hdr;
      81
      82          if ^ (bh_typ_ hdr = bt_tuple & bh_val_ hdr = 0) then
      83              call ermsg(14, 0);
      84          end if;
      85
      86          if ft_type(i) = f_mtuple ! ft_type(i) = f_proc then
      87              if (mttabp + ft_lim(i) > mttab_lim) call overfl('mttab');
      88
      89              do  j = 1 to ft_lim(i);
      90                  mttab(mttabp+j) = getsbi(0);
      91              end do;
      92
      93              ft_elmt(i) = mttabp;
      94              mttabp     = mttabp + ft_lim(i);
      95
      96          elseif is_fbase(i) then
      97              ft_num(i, f_lset)  = getsbi(0);
      98              ft_num(i, f_lmap)  = getsbi(0);
      99              ft_num(i, f_lpmap) = getsbi(0);
     100              ft_num(i, f_limap) = getsbi(0);
     101              ft_num(i, f_lrmap) = getsbi(0);
     102
     103          elseif is_fmap(i) & is_frem(i) then
     104              ft_tup(i) = getsbi(0);
     105          end if;
     106
     107          read sq1_file, hdr;
     108
     109          if ^ (bh_typ_ hdr = bt_tuple & bh_val_ hdr = 1) then
     110              call ermsg(15, 0);
     111          end if;
     112
     113          read sq1_file, hdr;
     114
     115          if ^ (bh_typ_ hdr = bt_tuple & bh_val_ hdr = 1) then
     116              call ermsg(15, 0);
     117          end if;
     118      end do;
     119$
     120$ symbol table
     121$
     122      $ read extent of current slice
     123      symtab_org = getsbi(0);   symtabp = getsbi(0);
     124
     125      $ compute new origines for val and names
     126      valp = 0;   namesp = 0;
     127
     128      do j = 1 to symtab_org;
     129          if vptr(j) > valp then
     130              valp = vptr(j) + vlen(j)-1;
     131          end if;
     132
     133          if name(j) > namesp then
     134              namesp = name(j) + (n_sorg(name(j))/ws)-1;
     135          end if;
     136      end do;
     137
     138      val_org = valp;   names_org = namesp;
     139
     140      $ read symbol table
     141      do i = symtab_org+1 to symtabp;
     142          symtab(i)   = 0;
     143
     144          read sq1_file, hdr;
     145
     146          if ^ (bh_typ_ hdr = bt_tuple & bh_val_ hdr = 0) then
     147              call ermsg(14, 0);
     148          end if;
     149
     150          name(i)     = getsbs(i);
     151          form(i)     = getsbi(0);
     152          alias(i)    = getsbi(0);
     153          is_repr(i)  = getsbb(0);
     154          is_temp(i)  = getsbb(0);
     155          is_stk(i)   = getsbb(0);
     156          is_read(i)  = getsbb(0);
     157          is_write(i) = getsbb(0);
     158          is_param(i) = getsbb(0);
     159          is_store(i) = getsbb(0);
     160          is_init(i)  = getsbb(0);
     161          is_seen(i)  = getsbb(0);
     162          is_back(i)  = getsbb(0);
     163          is_rec(i)   = getsbb(0);
     164
     165          fm = form(i);
     166
     167          if getsbb(0) then   $ entry has a value
     168              vlen(i) = getsbi(0);
     169
     170              if (valp + vlen(i) > val_lim) call overfl('val');
     171              read sq1_file, hdr;
     172
     173              if ^ (bh_typ_ hdr = bt_tuple & bh_val_ hdr = 0) then
     174                  call ermsg(14, 0);
     175              end if;
     176
     177              if is_fint(fm) then
     178                  val(valp+1) = getsbi(0);
     179
     180              elseif is_freal(fm) then
     181                  val(valp+1) = getsbr(0);
     182
     183              elseif is_fstr(fm) then
     184                  vptr(i) = getsbs(-i);
     185
     186              elseif ft_type(fm) = f_atom then
     187                  $ recall that booleans are the only legal constants
     188                  $ with form f_atom.
     189                  if getsbb(0) then
     190                      val(valp+1) = 0;
     191                  else
     192                      val(valp+1) = maxsi;
     193                  end if;
     194
     195              else
     196                  do j = 1 to vlen(i);
     197                      val(valp+j) = getsbi(0);
     198                  end do;
     199              end if;
     200
     201              read sq1_file, hdr;
     202
     203              if ^ (bh_typ_ hdr = bt_tuple & bh_val_ hdr = 1) then
     204                  call ermsg(15, 0);
     205              end if;
     206
     207              vptr(i) = valp + 1;
     208              valp    = valp + vlen(i);
     209          end if;
     210
     211          read sq1_file, hdr;
     212
     213          if ^ (bh_typ_ hdr = bt_tuple & bh_val_ hdr = 1) then
     214              call ermsg(15, 0);
     215          end if;
     216      end do;
     217$
     218$ block table
     219$
     220      blocktab_org = getsbi(0);   blocktabp = getsbi(0);
     221
     222      do i = blocktab_org+1 to blocktabp;
     223          b_first(i) = getsbi(0);
     224      end do;
     225$
     226$ code table
     227$
     228      codetab_org = getsbi(0);   codetabp = getsbi(0);
     229
     230      argtab_org = 0;
     231      argtabp    = 0;
     232
     233      do i = codetab_org+1 to codetabp;
     234          codetab(i) = 0;
     235
     236          read sq1_file, hdr;
     237
     238          if ^ (bh_typ_ hdr = bt_tuple & bh_val_ hdr = 0) then
     239              call ermsg(14, 0);
     240          end if;
     241
     242          opcode(i)  = getsbi(0);
     243          blockof(i) = getsbi(0);
     244          next(i)    = getsbi(0);
     245          cflag(i)   = getsbi(0);
     246          sflag(i)   = getsbi(0);
     247
     248          nargs(i)   = getsbi(0);
     249
     250          read sq1_file, hdr;
     251
     252          if ^ (bh_typ_ hdr = bt_tuple & bh_val_ hdr = 0) then
     253              call ermsg(14, 0);
     254          end if;
     255
     256          if (argtabp+nargs(i) > argtab_lim) call overfl('argtab');
     257
     258          do j = 1 to nargs(i);
     259              argtab(argtabp+j) = getsbi(0);
     260          end do;
     261
     262          argp(i) = argtabp;
     263          argtabp = argtabp + nargs(i);
     264
     265          read sq1_file, hdr;
     266
     267          if ^ (bh_typ_ hdr = bt_tuple & bh_val_ hdr = 1) then
     268              call ermsg(15, 0);
     269          end if;
     270
     271          read sq1_file, hdr;
     272
     273          if ^ (bh_typ_ hdr = bt_tuple & bh_val_ hdr = 1) then
     274              call ermsg(15, 0);
     275          end if;
     276      end do;
     277
     278 ..sq1
     279
     280
     281      end subr sgettb;
       1 .=member getsbi
       2      fnct getsbi(dummy);
       3
       4$ this routine reads a setl binary integer from the setl q1 file.
smfc  11$
smfc  12$ n.b.  the code here corresponds to the code of the getintli and getbli
smfc  13$ routines in the run-time library.  it does depend on the exact repre-
smfc  14$ sentation of setl long integers.  strictly speaking, we simulate the
smfc  15$ sequence
smfc  16$
smfc  17$       getbli(sq1_file, spec); get_intval(getsbi, spec);
smfc  18$
smfc  19$ without using the heap.
       5
       6
       7      size dummy(1);          $ dummy argument
       8
       9      size getsbi(ws);        $ return value
      10
      11 .-sq1    call abort('setl q1 inteface not available');
      12
      13 .+sq1.
      14
      15      size hdr(ws);           $ binary header word
      16      size word(ws);          $ binary data word
smfc  20      size sign(1);           $ sign of result
      17
      18      access q1vars;          $ access global q1 variables.
      19      access nscod;           $ access variables global to cod.
      20
      21
smfd  16      read sq1_file, hdr;
smfd  17
smfd  18      if bh_typ_ hdr = bt_sint then
smfd  19          getsbi = bh_val_ hdr;
smfd  20          return;
smfd  21
smfd  22      elseif bh_typ_ hdr = bt_int then
smfd  23          read sq1_file, word;
smfd  24
smfd  25      else
smfd  26          call ermsg(16, 0);
smfd  27      end if;
smfc  22
smfc  23      sign   = .f. ws,   1, word;  $ li_sign
smfc  24      getsbi = .f.  1, dds, word;  $ li_ddigit
smfc  25
smfc  26      if bh_val_ hdr = 2 then
smfc  27
smfc  28          read sq1_file, word;
smfc  29
smfc  30          .f. dds+1, ws-dds-1, getsbi = .f.  1, dds, word;
smfc  31
smfc  32      elseif bh_val_ hdr ^= 1 then
smfc  33          call ermsg(16, 0);
smfc  34      end if;
smfc  35
smfc  36      if (sign) getsbi = -getsbi;
      29
      30 ..sq1
      31
      32
      33      end fnct getsbi;
       1 .=member getsbr
       2      fnct getsbr(dummy);
       3
       4$ this routine reads a setl binary realfrom the setl q1 file.
       5
       6
       7      size dummy(1);          $ dummy argument
       8
       9      size getsbr(ws);        $ real returned as bitstring
      10
      11 .-sq1    call abort('setl q1 inteface not available');
      12
      13 .+sq1.
      14
      15      size hdr(ws);           $ binary header word
      16      size word(ws);          $ binary data word
      17
      18      access q1vars;          $ access global q1 variables.
      19      access nscod;           $ access variables global to cod.
      20
      21
      22      read sq1_file, hdr, word;
      23
      24      if ^ (bh_typ_ hdr = bt_real & bh_val_ hdr = 1) then
      25          call ermsg(17, 0);
      26      end if;
      27
      28      getsbr = word;
      29
      30 ..sq1
      31
      32
      33      end fnct getsbr;
       1 .=member getsbb
       2      fnct getsbb(dummy);
       3
       4$ this routine reads a setl boolean from the setl q1 file.
       5
       6
       7      size dummy(1);          $ dummy argument
       8
       9      size getsbb(1);         $ little 'boolean' returned
      10
      11 .-sq1    call abort('setl q1 inteface not available');
      12
      13 .+sq1.
      14
      15      size hdr(ws);           $ binary header word
      16      size word(ws);          $ binary data word
      17
      18      access q1vars;          $ access global q1 variables.
      19      access nscod;           $ access variables global to cod.
      20
      21
      22      read sq1_file, hdr, word;
      23
      24      if ^ (bh_typ_ hdr = bt_bool & bh_val_ hdr = 1) then
      25          call ermsg(18, 0);
      26      end if;
      27
      28      if ^ (word = 0 ! word = 1) then
      29          call ermsg(19, 0);
      30      end if;
      31
      32      getsbb = word;
      33
      34 ..sq1
      35
      36
      37      end fnct getsbb;
       1 .=member getsbs
       2      fnct getsbs(p);
       3
       4$ this routine reads the string value for symbol table entry 'p'
       5$ from the setl q1 file.
       6
       7
       8      size p(ws);             $ symbol table pointer
       9
      10      size getsbs(ps);        $ pointer returned
      11
stra  19 .-sq1.
stra  20      call abort('setl q1 interface not available');
      14 .+sq1.
      15
      16      size hdr(ws);           $ binary header word
      17      size word(ws);          $ binary data word
      18      size str(sds_sz);       $ string
      19      size org(ps);           $ sds origin of string
      20      size len(ps);           $ number of characters in string
      21      size words(ps);         $ number of data words
      22      size j(ps);             $ loop index
      23
      24      access q1vars;          $ access global q1 variables.
      25      access nscod;           $ access variables global to cod.
      26
      27
      28$
      29$ read and interpret header word
      30$
      31      read sq1_file, hdr;
stra  21
stra  22      if ^ (bh_typ_ hdr = bt_char ! bh_typ_ hdr = bt_string) then
      33          call ermsg(20, 0);
      34      end if;
      35
stra  23      if bh_typ_ hdr = bt_char then
stra  24          len = sc_max;
stra  25      else    $ bh_typ_ hdr = bt_string
stra  26          len = bh_val_ hdr;
stra  27      end if;
      37$
      38$ read the setl binary string and format it into an sds string
      39$
      40      $ initialize the sds string
      41      str = 0;
      42      org = .sds. len + 1;
      43
      44      $ compute number of data words to be read
      45      if len = 0 then
      46          words = 0;
      47      else
      48          words = ((len-1) / cpw) + 1;
      49      end if;
      50
      51      $ read string
stra  28      if bh_typ_ hdr = bt_char then
stra  29          .f. org-cs, cs, str = bh_val_ hdr;
stra  30      else    $ bh_typ_ hdr = bt_string
stra  31          do j = 1 to words;
stra  32              read sq1_file, word;
stra  33              .f. org-j*ws, ws, str = word;
stra  34          end do;
stra  35      end if;
      55
      56      $ form proper sds
      57      slen str = len;
      58      sorg str = org;
      59$
      60$ store the string into the compiler table
      61$
      62      words = org/ws;         $ number of words needed for sds
      63
      64      if p > 0 then           $ str is name(p)
      65          if len > 0 then
      66              if (namesp + words > names_lim) call overfl('names');
      67
      68              do j = 1 to words;
      69                  names(namesp+j) = .f. 1+(j-1)*ws, ws, str;
      70              end do;
      71
      72              getsbs = namesp + 1;
      73              namesp = namesp + words;
      74
      75          else                $ internal variable
      76              getsbs = 0;
      77          end if;
      78
      79      elseif p = 0 then       $ str is name of current scope
      80          getsbs = 0;
      81
      82      else                    $ str is value of string constant
      83          do j = 1 to words;
      84              val(valp+j) = .f. 1+(j-1)*ws, ws, str;
      85          end do;
      86
      87          vlen(-p) = words;
      88          getsbs = valp + 1;
      89      end if;
      90
      91 ..sq1
      92
      93      end fnct getsbs;
       1 .=member fixup
       2      subr fixup;
       3
       4$ this routine performs local optimizations when the global optimizer
       5$ is not available. it makes a single pass through the code doing
       6$ five things:
       7
       8$ 1. if looks for patterns such as:
       9
      10$    t := b op c;
      11$    a := t;
      12
      13$    where t is a temporary, and replaces them with a := b op c.
      14
      15$ 2. it types temporaries by looking at the opcode and input types
      16$    of the instruction which defines them.
      17
      18$ 3. if converts q1_set and q1_tup instructions into a series of
      19$    push instructions followed by a q1_set1 or q1_tup instruction.
      20
      21$ 4. it optimizes various patterns involving conditional branches.
      22
      23$ 5. it initializes the copy and share flags.
      24
      25      size fm(ps);            $ form of result
      26      size arg(ps);           $ argument
      27      size j(ps);             $ loop index
smfb 105      size dummy(ps);         $ dummy argument
smfb 106      size in2(ps), in3(ps);  $ local copies of operands
      28
      29      size shrtct(ps);        $ short-cuts branches to branches
      30
      31      access q1vars;          $ access global q1 variables.
      32      access nscod;           $ access variables global to cod.
      33
      34
      35      call clear_temps;       $ reinitialize for temporary allocation
      36
      37
      38      code_loop;              $ iterate over program
      39
      40          go to case(class(op)) in cl_minimum to cl_maximum;
      41
      42
      43      /case(cl_simp)/
      44
      45      /case(cl_noop)/
      46
      47          cont_loop;
      48
      49      /case(cl_min)/     $ min and max
      50
      51          fm = bin_type(op, fm2, fm3);
      52          go to esac1;
      53
      54      /case(cl_lessf)/
      55
      56          fm = deref_typ(fm2);
      57
      58          $ if a2 is a plex object, a3 must be an element of the domain
      59          if is_fplex(fm) & deref_typ(fm3) ^= ft_dom(fm) then
      60              call ermsg(11, a2);
      61          end if;
      62
      63          if (is_floc(fm)) fm = f_uset;
      64          if ( ^ opt_flag) cflag(now) = copy_yes;
      65          go to esac1;
      66
      67
      68      /case(cl_with)/
      69
      70          if ^ opt_flag then
      71              cflag(now) = copy_yes;
      72              if (op = q1_with) sflag(now) = yes;
      73          end if;
      74
      75          fm = deref_typ(fm2);
      76
      77          $ if a2 is a plex object, a3 must be an element of the base
      78          if is_fplex(fm) & deref_typ(fm3) ^= ft_elmt(fm) then
      79              call ermsg(11, a2);
      80          end if;
      81
      82          if     is_floc(fm)            then fm = f_uset;
smfa  29$$--          elseif op = q1_with &
smfa  30$$--                  is_fmap(fm) &
smfa  31$$--                  ft_mapc(fm) = ft_smap then fm = f_umap;
      83          elseif ft_type(fm) = f_mtuple then fm = f_tuple;
      84          end if;
      85
      86          go to esac1;
      87
      88      /case(cl_from)/       $ from
      89
      90          if ^ opt_flag then
      91              cflag(now) = copy_test;
      92          end if;
      93
      94          fm = deref_typ(fm2);   if (is_fplex(fm)) call ermsg(11, a2);
      95
      96          if is_temp(a2) then
      97              fm2 = fm;   is_repr(a2) = yes;
      98          end if;
      99
     100          if is_internal(a1) then
     101              fm1 = elmt_type(fm);   is_repr(a1) = yes;
     102          end if;
     103
     104          cont_loop;
     105
     106      /case(cl_umin)/     $ unary minus
     107
     108          fm = deref_typ(fm2);
     109          if ft_type(fm) = f_sint then fm = f_int; end if;
bnda   9          if op = q1_abs & is_fstr(fm) then  fm = f_sint;  end if;
     110
     111          go to esac1;
     112
     113      /case(cl_int)/   $ things yielding int
     114
     115          fm = f_int;
     116          go to esac1;
     117
     118      /case(cl_real)/         $ yield real
     119
     120          fm = f_real;
     121          go to esac1;
     122
     123      /case(cl_str)/  $ things yielding strings
     124
     125          if (is_fplex(deref_typ(fm2))) call ermsg(11, a2);
     126          fm = f_string;
     127          go to esac1;
     128
     129      /case(cl_bool)/         $ yield boolean
     130          $
     131          $ note that booleans are the short atoms 0 and maxsi
     132          $
     133          if (is_fplex(deref_typ(fm2))) call ermsg(11, a2);
     134          fm = f_atom;
     135          go to esac1;
     136
     137      /case(cl_uset)/         $ yield set(*)
     138
     139          if (is_fplex(deref_typ(fm2))) call ermsg(11, a2);
     140          fm = f_uset;
     141          go to esac1;
     142
     143      /case(cl_not)/   $ not
     144
     145          call fixnot;
     146          cont_loop;
     147
     148      /case(cl_rand)/   $ random
     149
     150          fm = deref_typ(fm2);   if (is_fplex(fm)) call ermsg(11, a2);
     151          if ^ is_fprim(fm) then fm = elmt_type(fm); end if;
     152          go to esac1;
     153
     154      /case(cl_arb)/  $ arb
     155
     156          fm = deref_typ(fm2);   if (is_fplex(fm)) call ermsg(11, a2);
     157          fm = elmt_type(fm);
     158          go to esac1;
     159
     160      /case(cl_stmt)/
     161
     162          cstmt_count = cstmt_count + 1;
     163          cont_loop;
     164
     165      /case(cl_call)/
     166
     167          cont_loop;
     168
     169      /case(cl_goto)/
     170
     171          call fixgo;
     172          cont_loop;
     173
     174      /case(cl_ifgo)/
smfb 107
smfb 108          if     op = q1_bif    then op = q1_if;
smfb 109          elseif op = q1_bifnot then op = q1_ifnot;
smfb 110          end if;
smfb 111
smfb 112          $ fall through to case(cl_ifgo1).
     175
     176      /case(cl_ifgo1)/
     177
     178          argn(now, nargs(now)) = shrtct(argn(now, nargs(now)));
     179          go to esac2;
     180
     181      /case(cl_case)/
     182
     183          is_casemap(a1) = yes;
     184          if (alias(a1) ^= 0) is_casemap(alias(a1)) = yes;
     185
     186          go to esac2;
     187
     188      /case(cl_lab)/
     189
     190          go to esac2;
     191
     192      /case(cl_entry)/
     193
     194          cstmt_count = estmt_count;
     195          go to esac2;
     196
     197      /case(cl_exit)/
     198
     199          go to esac2;
     200
     201      /case(cl_bin)/   $ binary operators
     202
     203$ this operations could be generated by 'a +:= b' or 'a -:= b'. in
     204$ either case we must check that 'a' is not a plex type.
     205
     206          if (is_fplex(deref_typ(fm2))) call ermsg(11, a2);
     207          if (is_fplex(deref_typ(fm3))) call ermsg(11, a3);
smfb 113
smfb 114          in2 = a2; call match_repr(dummy, in2, fm3); a2 = in2;
smfb 115          in3 = a3; call match_repr(dummy, in3, fm2); a3 = in3;
     208
     209          fm = bin_type(op, fm2, fm3);
     210
     211$ set the copy flag. there are four possibilities
     212
     213$ 1. we are doing a := b + c and b is a constant. we will always
     214$    have to copy b.
     215
     216$ 2. we are doing a := b + c and b is local. dont copy it.
     217
     218$ 3. we are doing a := a + b. copy a if its shared.
     219
     220$ 4. otherwise we are doing a := b + c. copy b.
     221
     222          if ^ opt_flag then
     223              if is_const(a2) then
     224                  cflag(now) = copy_yes;
     225
     226              elseif a1 = a2 then
     227                  cflag(now) = copy_test;
     228
     229              else
     230                  cflag(now) = copy_yes;
     231              end if;
     232          end if;
     233
     234          go to esac1;
     235
     236      /case(cl_nelt)/     $ nelt
     237
     238          if (is_fplex(deref_typ(fm2))) call ermsg(11, a2);
     239          fm = f_sint;
     240          go to esac1;
     241
     242      /case(cl_newat)/   $ newat
     243
     244          is_backpr(a1) = yes;
     245          fm = f_atom;
     246          go to esac1;
     247
     248      /case(cl_pred1)/        $ membership tests
     249
     250          fm = deref_typ(fm3);
     251
     252          $ if a3 is a plex object, a2 must be an element of the base
     253          if is_fplex(fm) & deref_typ(fm2) ^= ft_elmt(fm) then
     254              call ermsg(11, a3);
     255          end if;
     256
     257          call fixpred;
     258          cont_loop;
     259
     260
     261      /case(cl_pred2)/        $ binary predicates
     262
     263          if (is_fplex(deref_typ(fm2))) call ermsg(11, a2);
     264          if (is_fplex(deref_typ(fm3))) call ermsg(11, a3);
smfb 116
smfb 117          if op = q1_pos then op = q1_lt; swap(a2, a3); end if;
     265
     266          call fixpred;
     267          cont_loop;
     268
     269      /case(cl_asrt)/
     270
smfb 118          if op = q1_ifasrt then a1 = shrtct(a1); end if;
     271          go to esac2;
     272
     273      /case(cl_of)/           $ a1 := a2(a3)
     274
     275          fm = deref_typ(fm2);
     276
     277          if is_backpr(a3) then
     278              fm3 = dom_type(fm);   is_repr(a3) = yes;
     279          end if;
     280
     281          fm = compn_typ(fm, a3);
     282
     283          if (^ opt_flag & ^ is_funt(fm)) sflag(now) = yes;
     284
     285          go to esac1;
     286
     287      /case(cl_ofa)/          $ a1 := a2<>
     288
     289          if (^ opt_flag) sflag(now) = yes;
     290
     291          fm = deref_typ(fm2);
     292
     293          if is_backpr(a3) then
     294              fm3 = dom_type(fm);   is_repr(a3) = yes;
     295          end if;
     296
     297          fm = rset_type(fm);
     298
     299          go to esac1;
     300
     301
     302      /case(cl_subst)/        $ a1 := a2(a3...a4)
     303
     304          fm = deref_typ(fm2);
     305          if (ft_type(fm) = f_mtuple) fm = f_tuple;
     306
     307          go to esac1;
     308
     309      /case(cl_sof)/          $ a1(a2) := a3
     310
     311          fm = deref_typ(fm1);
     312
     313          if is_backpr(a2) then
     314              fm2 = dom_type(fm);   is_repr(a2) = yes;
     315          end if;
     316
     317          if is_backpr(a3) then
     318              fm3 = compn_typ(fm, a2);   is_repr(a3) = yes;
     319          end if;
     320
     321          if ^ opt_flag then
     322              cflag(now) = copy_test;   sflag(now) = yes;
     323          end if;
     324
     325          go to esac3;
     326
     327
     328      /case(cl_sofa)/         $ a1<> := a3
     329
     330          fm = deref_typ(fm1);
     331
     332          if is_backpr(a2) then
     333              fm2 = dom_type(fm);   is_repr(a2) = yes;
     334          end if;
     335
     336          if is_backpr(a3) then
     337              fm3 = rset_type(fm);   is_repr(a3) = yes;
     338          end if;
     339
     340          if ^ opt_flag then
     341              cflag(now) = copy_test;   sflag(now) = yes;
     342          end if;
     343
     344          go to esac3;
     345
     346
     347      /case(cl_ssubst)/       $ a1(a2...a3) := a4
     348
     349          if (^ opt_flag) cflag(now) = yes;
     350
     351          go to esac3;
     352
     353      /case(cl_argin)/
     354
     355          if is_backpr(a1) then
     356              fm1 = arg_type(a2, symval(a3));
     357          end if;
     358
     359          go to esac2;
     360
     361      /case(cl_argout)/    $ stack pop
     362
     363          fm = arg_type(a2, symval(a3));
     364          go to esac1;
     365
     366
     367      /case(cl_push)/  $ push element for set former
     368
     369$ note that the input to the push instruction also appears as an input
     370$ to the setformer, so we do not free the temporary yet.
     371
     372          cont_loop;
     373
     374      /case(cl_free)/
     375
     376          cont_loop;
     377
     378
     379      /case(cl_asn)/      $ a1 = a2
     380
     381
     382          call fixasn;
     383          cont_loop;
     384
     385      /case(cl_st)/  $ set and tuple formers
     386
     387      /case(cl_st1)/
     388
     389      /case(cl_st2)/          $ q1_dom and q1_range
     390
     391          if (is_temp(a1) & ^ is_repr(a1)) is_backpr(a1) = yes;
     392          fm = f_gen;
     393          go to esac1;
     394
     395
     396      /case(cl_next)/
     397
     398          fm = deref_typ(fm3);   if (is_fplex(fm)) call ermsg(11, a3);
     399
     400          $ if a3 is an internal variable, it will have been
     401          $ set to the form of the object we want to iterate
     402          $ over.  at this point we can improve the form
     403          $ propagation by assigning the dereferenced mode
     404          $ to a1.
     405          if is_internal(a3) then
     406              fm3 = fm;    is_repr(a3) = yes;
     407          end if;
     408
     409          $ if a1 is an internal variable, give it the element
     410          $ type of a3
     411          if is_internal(a1) then
     412              fm1 = elmt_type(fm);    is_repr(a1) = yes;
     413          end if;
     414
     415          cont_loop;
     416
     417      /case(cl_nextd)/
     418
     419          fm = deref_typ(fm3);   if (is_fplex(fm)) call ermsg(11, a3);
     420
     421          if is_internal(a3) then
     422              fm3 = fm;    is_repr(a3) = yes;
     423          end if;
     424
     425          $ if a1 is an internal variable, give it the domain type
     426          $ of a3
     427          if is_internal(a1) then
     428              fm1 = dom_type(fm);    is_repr(a1) = yes;
     429          end if;
     430
     431          cont_loop;
     432
     433      /case(cl_ok)/
     434
     435      /case(cl_fail)/
     436
     437      /case(cl_succeed)/
     438
     439          if (^ back_flag) call ermsg(13, 0);
     440          cont_loop;
     441
     442      /case(cl_debug)/
     443
     444          if (a1 = sym_cq1cd) call q1dump;
     445
     446          cont_loop;
     447
     448
     449      /esac1/
     450
     451$ we reach here for all instructions which define new temporaries.
     452$ reserve a temporary for the output and free the temporaries for
     453$ the inputs.
     454
     455          if (opt_flag) cont_loop;
     456
     457          if (is_temp(a1)) call set_temp(a1, fm);
     458
     459          do j = 2 to nargs(now);
     460              arg = argn(now, j);
     461
     462              if (is_temp(arg)) call free_temp(arg);
     463          end do;
     464
     465          cont_loop;
     466
     467
     468      /esac2/
     469
     470$ we reach here for instructions which do not define new temporaries.
     471$ free all the temporaries used for inputs.
     472
     473          if (opt_flag) cont_loop;
     474
     475          do j = 1 to nargs(now);
     476              arg = argn(now, j);
     477
     478              if (is_temp(arg)) call free_temp(arg);
     479          end do;
     480
     481          cont_loop;
     482
     483
     484      /esac3/
     485
     486$ this exit is executed if the first argument is both an input and
     487$ an output:  return all remaining temporaries.
     488
     489          if (opt_flag) cont_loop;
     490
     491          do j = 2 to nargs(now);
     492              arg = argn(now, j);
     493
     494              if (is_temp(arg)) call free_temp(arg);
     495          end do j;
     496
     497      end_loop;
     498
     499      if (q1cd_flag) call q1dump;  $ dump modified q1 if desired
     500
     501
     502      end subr fixup;
       1 .=member fixasn
       2      subr fixasn;
       3
       4$ this routine cleans up simple assignments.
       5
       6$ we begin by looking for the case
       7
       8$     t := b op c;
       9$     a := t;
      10
      11$ where the temporary 't' is unnecessary. this is true if either:
      12
      13$ 1. 'a' is local and either:
      14
      15$    a. we are doing +, *, or - and 'a', 'b',  and 'c' have
      16$       similar reprs and 'a' and 'c' are not the same variable.
      17$       note that we are prepared to commute the operands of
      18$       + and * so that the assignment can be merged.
      19
      20$    b. we are doing an enumerative set former.
      21
      22$    c. we are doing 't := b; a := t;' and 'a' and 'b' have the same
      23$       reprs.
      24$
      25$ 2. 't' has a type (or mode) that can be assigned to 'a' without
      26$    conversion.
      27$
      28$ we also look for the case:
      29
      30$    t := iterrative set former;
      31$    a := t;
      32
      33$ and propagate the type of 'a' back to 't'.
      34
      35      size xop(ps);           $ previous opcode
      36      size xa1(ps);           $ previous arg1
      37      size xa2(ps);           $ previous arg2
      38      size xa3(ps);           $ previous arg3
      39      size fm(ps);            $ dereferenced form
      40
      41      access q1vars;          $ access global q1 variables.
      42      access nscod;           $ access variables global to cod.
      43
      44      xop = opcode(prev);
      45      xa1 = arg1(prev);
      46      xa2 = arg2(prev);
      47      xa3 = arg3(prev);
      48
      49$ see if we can merge the assignment.
      50
      51      if ^ is_temp(a2) ! a2 ^= xa1 then
      52          go to nmerge;
      53
      54      elseif is_floc(fm1) then
      55          if xop = q1_add ! xop = q1_mult ! xop = q1_sub then
      56              if (^ similar_repr(fm1, form(xa2))) go to nmerge;
      57              if (^ similar_repr(fm1, form(xa3))) go to nmerge;
      58
      59              if a1 = xa2 then
      60                  go to merge;
      61
      62              elseif a1 = xa3 & xop ^= q1_sub then
      63                  swap(arg2(prev), arg3(prev));
      64                  go to merge;
      65              end if;
      66
      67              go to nmerge;
      68
      69          elseif xop = q1_with ! xop = q1_less ! xop = q1_lessf then
      70              if a1 = xa2 then
      71                  if xop = q1_with & is_backpr(xa3) then
      72                      form(xa3) = elmt_type(fm1);   is_repr(xa3) = yes;
      73                  end if;
      74
      75                  go to merge;
      76              end if;
      77
      78              go to nmerge;
      79
      80          elseif xop = q1_set ! xop = q1_dom ! xop = q1_range then
      81              go to merge;
      82
      83          elseif xop = q1_set1 then
      84              go to set1;
      85
      86          elseif xop = q1_asn then
      87              if (same_repr(fm1, form(xa2))) go to merge;
      88              go to nmerge;
      89
      90          else
      91              go to nmerge;
      92          end if;
      93
      94      else
      95          if ^ is_temp(a1) ! ^ is_seen(a1) then
      96              $ we can attempt to propagate forms backwards
      97
      98              fm = deref_typ(fm1);
      99
     100              if class(xop) = cl_st ! class(xop) = cl_st2 then
     101                  fm2 = fm;
     102                  go to merge;
     103
     104              elseif xop = q1_newat
     105                      & ft_type(fm1) = f_elmt
     106                      & ft_type(ft_base(fm1)) = f_pbase then
     107                  fm2 = fm1;
smfb 119
smfb 120              elseif ft_type(fm) = f_sint then
smfb 121                  if rem ^= err_full & fm = fm1 & fm = form(xa2) then
smfb 122                      if (class(xop) = cl_umin) go to merge;
smfb 123                      if class(xop) = cl_bin ! class(xop) = cl_min then
smfb 124                          if (fm = form(xa3)) go to merge;
smfb 125                      end if;
smfb 126                  end if;
     108
     109              elseif is_pre(xop) & ft_type(fm) ^= f_mtuple then
     110                  fm2 = fm;
     111
     112                  if is_backpr(xa2) &
     113                          (xop = q1_with ! class(xop) = cl_bin) then
     114                      form(xa2) = fm;   is_repr(xa2) = yes;
     115                  end if;
     116                  if is_backpr(xa3) then
     117                      if xop = q1_with then
     118                          form(xa3) = elmt_type(fm);
     119                          is_repr(xa3) = yes;
     120                      elseif class(xop) = cl_bin then
     121                          form(xa3) = fm;   is_repr(xa3) = yes;
     122                      end if;
     123                  end if;
     124              end if;
     125          end if;
     126
     127          if is_internal(a1) & is_seen(a1) then
     128              $ we attempt a forward propagation  step  before  we  test
     129              $ whether we can merge the assignment.   this  will  catch
     130              $ cases where the temporary has received a  more  specific
     131              $ form previously, and for this reason  we  cannot  assign
     132              $ the temporary to the internal variable.  the  code  here
     133              $ is identical to the code below.
     134              if is_fint(fm2) then        $ case (c) below
     135                  fm = f_int;
     136              elseif is_floc(fm2) then    $ should never happen
     137                  fm = f_uset;    $ cannot introduce a new local object
     138              else
     139                  fm = fm2;
     140              end if;
     141
     142              if (fm ^= form(a1) & a2 ^= sym_om) form(a1) = f_gen;
     143          end if;
     144
     145          if (can_assign(fm1, fm2)) go to merge;
     146          if (class(xop) = cl_st1) go to set1;
     147          go to nmerge;
     148      end if;
     149
     150/merge/      $ merge assignment
     151
     152      arg1(prev) = a1;
     153      next(prev) = next(now);
     154
     155$ if we are merging 't := a op b; a := t' then we may be able to
     156$ change an unconditional copy of 'a' to a conditional one.
     157
     158      if (a1 = xa2 & cflag(prev) = copy_yes) cflag(prev) = copy_test;
     159
     160      if is_temp(a1) then
     161          if is_floc(fm2) then    $ cannot introduce a new local object
     162              call set_temp(a1, f_uset);
     163          else
     164              call set_temp(a1, fm2);
     165          end if;
     166      end if;
     167
     168      call drop_temp(a2);  $ temp not needed
     169
     170      $ the next statement is justified for the following reason:
     171      $ this routine only returns to the cl_asn case in fixup.  it
     172      $ is followed by a cont_loop, which will set prev to now, and
     173      $ now to next(now).  by resetting now here, we account for the
     174      $ instruction we just deleted.
     175      now = prev;
     176
     177      return;
     178
     179
     180/set1/        $ iterative set former
     181
     182      if is_temp(a1) & is_seen(a1) then
     183          fm1 = f_gen;
     184      else
     185          fm2 = deref_typ(fm1);    is_repr(a2) = yes;
     186      end if;
     187
     188      if (is_fplex(fm2)) call ermsg(11, a1);
     189
     190      call free_temp(a2);
     191      return;
     192
     193/nmerge/    $ dont merge
     194
     195      $ make sure we are not assigning from or to a plex object
     196      if (is_fplex(deref_typ(fm1))) call ermsg(11, a1);
     197      if (is_fplex(deref_typ(fm2))) call ermsg(11, a2);
     198
     199      if (^ opt_flag) sflag(now) = yes;
     200      if (is_temp(a2)) call free_temp(a2);
     201
     202
     203$ next we handle two special cases:
     204
     205$ 1. if we are assigning to a temporary, call set_temp.
     206$    note that we never assign a temporary a local type. instead
     207$    we assign it set(*).
     208
     209$ 2. assignments to unreprd internal variables. there are
     210$    three cases where this will arise:
     211
     212$     a. before we do a multiple assignment [a, b, c] = rhs we
     213$       assign rhs to an internal variable. in this case we can
     214$       give the internal variable the same type as 'rhs'.
     215
     216$     b. before we start the iteration 'x _ s' we assign 's' to an
     217$       internal variable. once again we can give the variable the
     218$       type of the rhs.
     219
     220$     c. we a shadow variable for 'i' in '! i = e1 ... e2'. in this
     221$        case the shadow variable is defined twice, once at the top
     222$        of the loop and once at the bottom. here we cannot give
     223$        i the type of e1. the most we can say is that it is an integer.
     224
     225      if is_temp(a1) then
     226          if is_floc(fm2) then
     227              call set_temp(a1, f_uset);
     228          else
     229              call set_temp(a1, fm2);
     230          end if;
     231
     232      elseif is_internal(a1) then
     233          if is_fint(fm2) then     $ case (c) above
     234              fm = f_int;
     235          elseif is_floc(fm2) then $ cannot introduce a new local object
     236              fm = f_uset;
     237          else
     238              fm = fm2;
     239          end if;
     240
     241          if is_seen(a1) then
     242              if (fm ^= form(a1) & a2 ^= sym_om) form(a1) = f_gen;
     243          elseif ^ is_repr(a1) then
     244              form(a1) = fm;   is_repr(a1) = yes;   is_seen(a1) = yes;
     245          end if;
     246      end if;
     247
     248      return;
     249
     250      end subr fixasn;
       1 .=member fixgo
       2      subr fixgo;
       3
       4$ this routine processes unconditional gotos. we look for three special
       5$ cases:
       6
       7$ 1. branches to the next instruction, i.e. 'go to l; l:'
       8
       9$ 2. successive branches to the same instruction, i.e.
      10$    'go to l1; l2: go to l1;'
      11
      12$ 3. branches to a label followed by another goto.
      13
      14      size block(ps);         $ block after current block
      15      size first(ps);         $ first instruction of block
      16      size p(ps);             $ code pointers
      17      size targ(ps);          $ target of goto
      18
      19      size shrtct(ps);        $ short-cuts branches to branches
      20
      21      access q1vars;          $ access global q1 variables.
      22      access nscod;           $ access variables global to cod.
      23
      24$ look for case 1 and get a pointer to the next instruction.
      25
      26      if next(now) = 0 then  $ goto is at end of block
      27          block = blockof(now) + 1;
      28          first = b_first(block);
      29          p     = next(first);
      30
      31          if arg1(first) = a1 then  $ delete goto
      32              next(prev) = 0;
      33              return;
      34          end if;
      35
      36      else
      37          p = next(now);
      38      end if;
      39
      40$ look for case 2
      41      if stmt_flag < 2 then   $ can skip statement quadruples
      42          while p ^= 0; if (opcode(p) ^= q1_stmt) quit while p;
      43              p = next(p);
      44          end while;
      45      end if;
      46
      47      if opcode(p) = q1_goto & arg1(p) = a1 then  $ delete first goto
      48          next(prev) = next(now);
      49          return;
      50      end if;
      51
      52      $ look for branches to a label followed by an unconditional branch
      53      arg1(now) = shrtct(arg1(now));
      54
      55      return;
      56
      57      end subr fixgo;
       1 .=member fixnot
       2      subr fixnot;
       3
       4$ this routine is called to fix up 'not' instructions. it
       5$ replaces 'if not not a' with 'if a'.
       6
       7      size p(ps);             $ pointer to next instruction
       8      size op1(ps);           $ its opcode
       9      size arg(ps);           $ argument
      10      size even(1);           $ indicates even number of 'nots'
      11
      12      access q1vars;          $ access global q1 variables.
      13      access nscod;           $ access variables global to cod.
      14
      15      even = no;
      16      arg = arg1(now);
      17      p    = next(now);
      18
      19      while opcode(p) = q1_not & is_temp(arg) & arg2(p) = arg;
      20          arg  = arg1(p);
      21          p    = next(p);
      22          even = ^ even;
      23      end while;
      24
      25$ if p points to a branch instruction then we do four things:
      26
      27$ a. delete all the 'not' instructions and set the argument of
      28$    the branch to the argument of the first 'not'.
      29
      30$ b. if there are an odd number of 'not' instructions, compliment
      31$    the branch.
      32
      33$ c. advance 'now' to point to the branch instruction, dropping
      34$    all the temporaries used by the 'not' instructions.
      35
      36$ d. free the temporary used by the branch.
      37
      38$ otherwise we process the 'not' instruction like any other unary
      39$ operator.
      40
      41      op1 = opcode(p);
smfb 127
smfb 128      if     op1 = q1_bif    then op1 = q1_if;
smfb 129      elseif op1 = q1_bifnot then op1 = q1_ifnot;
smfb 130      end if;
smfb 131
smfb 132      opcode(p) = op1;
      42
      43      if class(op1) = cl_ifgo & is_temp(arg) & arg1(p) = arg then
      44          $ delete the not's
      45          arg1(p)    = arg2(now);
      46
      47          if ^ even then  $ flip the branch
      48              if op1 = q1_if then
      49                  opcode(p) = q1_ifnot;
      50              else
      51                  opcode(p) = q1_if;
      52              end if;
      53          end if;
      54
      55$ reset now and drop all the unused temporaries.
      56          until now = p;
      57              call drop_temp(arg1(now));
      58              now = next(now);
      59          end until;
      60
      61          next(prev) = now;
      62
      63          if (is_temp(a1)) call free_temp(a1);
      64
      65      else  $ treat as normal unary operatororary
      66          call set_temp(a1, f_atom);
      67          if (is_temp(a2)) call free_temp(a2);
      68      end if;
      69
      70
      71      end subr fixnot;
       1 .=member fixpred
       2      subr fixpred;
       3
       4$ this routine is called during the fixup pass whenever we
       5$ see a predicate such as '=' or '<'. we see whether the
       6$ predicate is used in a branch instruction, and perform
       7$ various peephole optimizations.
       8
       9      size p(ps);             $ pointer to next instruction
      10      size p1(ps);            $ pointer to instruction after p
      11      size p2(ps);            $ pointer to target of goto
      12      size pp(ps);            $ extra pointer
      13      size even(1);           $ indicates even number of 'nots'
      14      size arg(ps);           $ argument of 'not' instruction
      15      size op1(ps);           $ next opcode
      16      size t2(ps);            $ a temporary
      17      size l1(ps);            $ a label
      18      size l3(ps);            $ another label
      19      size i(ps);             $ the instruction after l1
      20
      21      size getlab(ps);        $ gets new label
      22      size shrtct(ps);        $ short-cuts branches to branches
      23
      24      access q1vars;          $ access global q1 variables.
      25      access nscod;           $ access variables global to cod.
      26
      27$ we begin by seeing whether the predicates is followed by a series
      28$ of 'not' instructions.
      29
      30      even = yes;   $ indicates even number of 'not-s'
      31      arg  = a1;  $ output of previous instruction
      32      p    = next(now);
      33
      34      while opcode(p) = q1_not & is_temp(arg) & arg2(p) = arg;
      35          arg = arg1(p);
      36          p   = next(p);
      37          even = ^ even;
      38      end while;
      39
      40$ now see if the expression is used in a branch
      41
      42      op1 = opcode(p);
smfb 133
smfb 134      if     op1 = q1_bif    then op1 = q1_if;
smfb 135      elseif op1 = q1_bifnot then op1 = q1_ifnot;
smfb 136      end if;
smfb 137
smfb 138      opcode(p) = op1;
      43
      44      if class(op1) = cl_ifgo & is_temp(arg) & arg1(p) = arg then
      45
      46$ drop the temporaries defined by the predicate and the 'not'
      47$ instructions.
      48          pp = now;
      49
      50          until pp = p;
      51              if (is_temp(arg1(pp))) call drop_temp(arg1(pp));
      52              pp = next(pp);
      53          end until;
      54
smfb 139$ change the predicate to a branch instruction
      56          if (even & op1 = q1_if) ! (^ even & op1 = q1_ifnot) then
      57              op = if_op(op);
      58          else
      59              op = ifn_op(op);
      60          end if;
      61
      62          opcode(now) = op; $ change predicate to branch
      63          arg1(now)   = arg2(now);
      64          arg2(now)   = arg3(now);
      65          arg3(now)   = arg2(p);
      66
      67$ delete the original branch
      68          next(now)   = next(p);
      69
      70$ free the inputs of the branch
      71          if (is_temp(a1)) call free_temp(a1);
      72          if (is_temp(a2)) call free_temp(a2);
      73
      74          $ look for branches to a label followed by an unconditional
      75          $ branch
      76          arg3(now) = shrtct(arg3(now));
      77
      78          return;
      79      end if;
      80
      81$ otherwise process the predicate like any binary operator
      82      call set_temp(a1, f_atom);
      83
      84      if (is_temp(a2)) call free_temp(a2);
      85      if (is_temp(a3)) call free_temp(a3);
      86
      87
      88      end subr fixpred;
       1 .=member shrtct
       2      fnct shrtct(arg);
       3$
       4$ this routine returns the label of the first non-empty block that can
       5$ reached from the label arg.
       6$
       7      size shrtct(ps);        $ label of first non-emtpy block
       8
       9      size arg(ps);           $ symtab pointer of block label
      10
      11      size i1(ps), i2(ps);    $ q1 code pointers
      12      size j(ps);             $ counter to limit transitive closure
      13      size lab(ps);           $ symtab pointer of block label
      14
      15      access q1vars;          $ access global q1 variables.
      16      access nscod;           $ access variables global to cod.
      17
      18
      19      lab = arg;              $ copy argument
      20
      21      do j = 1 to 10;         $ for at most ten branches to branches
suna  23          if symtype(lab) ^= f_lab then
suna  24              put ,'symtype(lab) = ' :symtype(lab),i ,', lab = ' :lab,i
suna  25                  ,skip;
suna  26              call ermsg(27, 0);
suna  27          end if;
      23          i1 = symval(lab);   $ q1_label or q1_tag instruction
suna  28          if opcode(i1) ^= q1_label & opcode(i1) ^= q1_tag then
bnda  10              put ,'arg = ' :arg,i ,', lab = ' :lab,i ,', i1 = ' :i1,i
bnda  11                  ,', opcode(i1) = ' :opcode(i1),i ,skip;
suna  30              call ermsg(28, 0);
suna  31          end if;
      25          i2 = next(i1);      $ instruction after label
      26
      27          if stmt_flag < 2 then   $ can skip statement quadruples
      28              while i2 ^= 0; if (opcode(i2) ^= q1_stmt) quit while;
      29                  i2 = next(i2);
      30              end while;
      31          end if;
      32
      33          if i2 = 0 then      $ implicit goto at end of block
      34              i2 = b_first(blockof(i1) + 1);
suna  32              if (i2 = 0) call ermsg(29, 0);
suna  33              if opcode(i1) ^= q1_label & opcode(i1) ^= q1_tag then
suna  34                  put ,'opcode(i2) = ' :opcode(i2),i ,skip;
suna  35                  call ermsg(30, 0);
suna  36              end if;
      36          elseif opcode(i2) ^= q1_goto then
      37              quit do j;
      38          end if;
      39          lab = arg1(i2);
      40      end do j;
      41
      42      shrtct = lab;
      43
      44
      45      end fnct shrtct;
       1 .=member settemp
       2      subr set_temp(t1, fm);
       3
       4$ this routine is called during the fixup pass to process each
       5$ instruction which defines a temporary. t1 is the temporary and
       6$ fm is its type. we do two things:
       7
       8$ 1. set the form of t1 to fm.
       9
      10$ 2. see if there are any free temps available. if so, we make
      11$    t1 an alias for one of the free temps.
      12
      13$ some temporaries, such as those yielded by conditional
      14$ expressions, are defined several times. the first time we process
      15$ such a temporary, we set its is_seen flag. the next time, we
      16$ simply return.
      17
      18$ we maintain a stack called 'temptab' containing all currently
      19$ available temporaries.
      20
      21$ temporaries are divided into to categories: those which are saved
      22$ during backtracking and those which aren't. we cannot store
      23$ temporaries of different classes in the same list. since
      24$ backtracked temporaries are very rare, we do not even try to
      25$ merge them.
      26$
      27$ also note that we can not alias a typed and an untyped variable, as
      28$ this would derail the garbage collector.  we assume, for simplicity,
      29$ that untyped temporaries are rare, and do not attempt to find free
      30$ untyped temporaries.
      31
      32
      33      nameset temptab;
      34          +*  temptab_lim  =  500  **
      35
      36          size temptab(ps);
      37          dims temptab(temptab_lim);
      38
      39          size temptabp(ps);   $ pointer to last entry used
      40          data temptabp = 0;
      41
      42      end nameset;
      43
      44      size t1(ps),  $ original temp
      45           fm(ps);  $ its type
      46
      47      size t2(ps);  $ free temp
      48
      49      access q1vars;          $ access global q1 variables.
      50      access nscod;           $ access variables global to cod.
      51
      52
      53      if (opt_flag) return;
      54
      55$ if the temporary is defined twice with different types, set
      56$ its type to general.
      57
      58      if is_seen(t1) then
      59          if (fm ^= form(t1)) form(t1) = f_gen;
      60          return;
      61      end if;
      62
      63
      64      form(t1)    = fm;   $ install type
      65      is_repr(t1) = yes;
      66      is_seen(t1) = yes;
      67
      68      if (is_back(t1) & back_flag) return;
      69      if (is_funt(fm))             return;
      70
      71      if (temptabp = 0) return;   $ no free temps
      72
      73      t2       = temptab(temptabp);  $ get first free temp
      74      temptabp = temptabp - 1;
      75
      76      alias(t1)    = t2;     $ make t1 an alias for t2
      77      is_store(t1) = no;
      78
      79$ indicate that there is an alias for t2
      80      is_alias(t2) = yes;
      81
      82
      83      end subr set_temp;
       1 .=member freetemp
       2      subr free_temp(t1);
       3
       4$ this routine frees a temporary 't1'. this is done in two steps:
       5
       6$ 1. set t2 = t1. if t2 is an alias, set t2 = alias(t2).
       7$ 2. add t2 to temptab.
       8
       9      size t1(ps);   $ original temporary
      10
      11      size t2(ps);   $ possible alias
      12
      13      access temptab;
      14      access q1vars;          $ access global q1 variables.
      15      access nscod;           $ access variables global to cod.
      16
      17
      18      if (opt_flag) return;
      19
      20      if (is_back(t1) & back_flag) return;
      21
      22      t2 = t1;
      23      if (alias(t2) ^= 0) t2 = alias(t2);
      24
      25      countup(temptabp, temptab_lim, 'temptab');
      26      temptab(temptabp) = t2;
      27
      28
      29      end subr free_temp;
       1 .=member droptemp
       2      subr drop_temp(t1);
       3
       4$ this routine is called when we reserve a temporary for 't1' and
       5$ then discover that it is not actually needed. there are three
       6$ possibilities:
       7
       8$ 1. t1 is an alias for t2. add t2 to temptab.
       9
      10$ 2. there is an alias for t1. add t1 to temptab.
      11
      12$ 3. otherwise clear t1's is_store bit.
      13
      14      size t1(ps);  $ original temp
      15
      16      access temptab;
      17      access q1vars;          $ access global q1 variables.
      18      access nscod;           $ access variables global to cod.
      19
      20
      21      if (opt_flag) return;
      22
      23      if (is_back(t1) & back_flag) return;
      24
      25      if alias(t1) ^= 0 then
      26          countup(temptabp, temptab_lim, 'temptab');
      27          temptab(temptabp) = alias(t1);
      28
      29      elseif is_alias(t1) then
      30          countup(temptabp, temptab_lim, 'temptab');
      31          temptab(temptabp) = t1;
      32
      33      else
      34          is_store(t1) = no;
      35      end if;
      36
      37
      38      end subr drop_temp;
       1 .=member cltemps
       2      subr clear_temps;
       3
       4$ this routine reinitializes temptab
       5
       6      access temptab;
       7      access q1vars;          $ access global q1 variables.
       8      access nscod;           $ access variables global to cod.
       9
      10      temptabp = 0;
      11      return;
      12
      13      end subr clear_temps;
       1 .=member alloc
       2      subr alloc;
       3
       4$ this routine allocates storage in the run time symbol
       5$ table.
       6
       7$ the following types of symbols require storage
       8
       9$ 1. variables
      10$ 2. constants
      11$ 3. bases
      12
      13$ in addition each distinct data type requires a symbol table
      14$ entry which is used to store the standard representation of
      15$ omega for that type.
      16
      17$ the symbol table is located at the high end of the heap.
      18$ the variable 'sym_end' points to the end of the symbol
      19$ table. every time we adjust sym_end we must check that
      20$ we have not gone into the area used for code, etc.
      21
      22$ symbol table entries may be divided into storage classes
      23$ based on whether the symbol is typed or untyped, static
      24$ or stacked, etc. the symbols for each scope are stored
      25$ contiguously, sorted by storage class.
      26
      27$ storage allocation is done in four steps:
      28
      29$ 1. iterate over the current page of symtab, assigning each symbol
      30$    which requires storage an offset within the appropriate block.
      31$    as we allocate offsets, we build a map 'blocklen' sending
      32$    each block into its length.
      33
      34$    during this pass we also check whether we are using untyped
      35$    integers or reals while the library is in the full error
      36$    checking mode. if so, we issue a diagnostic.
      37
      38$    constant bases recieve two symbol table entries. the first is
      39$    used for the base itself. the second is used for a tuple
      40$    containing all the elements of the base in order of their
      41$    ebindx. this tuple is used to unpack values stored in packed
      42$    maps and tuples.
      43
      44$    set the ft_samp field of bases to point to the base.
      45
      46
      47$ 2. iterate over the current page of formtab, assigning each
      48$    sample within the appropriate block.
      49
      50$    there are four cases in which we do not allocate storage for
      51$    a separate sample value:
      52
      53$    a. standard based types
      54
      55$       the types f_lset, f_rset, etc. are never used as reprs for
      56$       actual variables, and do not receive sample values.
      57
      58$    b. local types with ft_pos = 0.
      59
      60$       each time the semantic pass processes a repr for a local
      61$       object it creates a copy of the original formtab entry
      62$       with a unique ft_pos. the original entry has an ft_pos
      63$       of zero. since it is never used as the type of any variable,
      64$       it does not require storage.
      65
      66$    c. standard packed tuple
      67
      68$       the type f_ptuple is never used as repr for any actual variable,
      69$       and therefor does not receive a sample value.
      70
      71$    d. bases:
      72
      73$       the ft_samp field of a base points to the base itself rather
      74$       than a separate sample value.
      75
      76$ 3. allocate a skip word and initialize it.
      77
      78$ 4. integrate blocklen and produce a map blockorg giving the
      79$    origin of each block.
      80
      81$ 6. make a second pass through symtab and formtab, mapping offsets
      82$    into addresses, and build the run time names table.
      83$    when we iterate through formtab, we set the ft_samp field
      84$    of each base to the address of the base.
      85
      86
      87      size cl(ps);            $ storage class
      88      size fm(ps);            $ form of variable
      89      size len(ps);           $ length of block
      90      size org(ps);           $ origin of block
      91      size addr(ps);          $ final address
      92      size j(ps);             $ loop index
      93
      94      size skip_offs(ps);     $ offset of skip word
      95      size skip_addr(ps);     $ address of skip word
      96      size skip_valu(ps);     $ value of skip word
      97
      98      size sclass(ps);        $ functions called
      99      size fsclass(ps);
     100
     101      access q1vars;          $ access global q1 variables.
     102      access nscod;           $ access variables global to cod.
     103
     104
stra  36      do j = scl_min to scl_max;  $ initialise blocklen
     106          blocklen(j) = 0;
     107      end do;
     108
     109$ assign offsets within blocks
     110      do j = symtab_org+1 to symtabp;
     111
     112          fm = form(j);
     113          if (is_funt(fm) & err_mode = err_full) call ermsg(12, j);
     114
     115          if (^ is_store(j)) cont;
     116
     117          cl           = sclass(j);
     118          address(j)   = blocklen(cl);
     119          blocklen(cl) = blocklen(cl) + 1;
     120
     121          $ allocate a skip word after untyped parameters
stra  37          if cl = scl_param & is_funt(fm) then
     123              blocklen(cl) = blocklen(cl) + 1;
     124          end if;
     125
     126          if is_fbase(fm) then
     127              ft_samp(fm) = j; $ points back to base
     128
     129              if is_const(j) then   $ allocate extra word
     130                  blocklen(cl) = blocklen(cl) + 1;
     131              end if;
     132          end if;
     133      end do;
     134
     135      do j = formtab_org+1 to formtabp;
     136          if (is_fbsd(j) & j <= f_max)    cont; $ f_lset, etc.
     137          if (is_floc(j) & ft_pos(j) = 0) cont;
     138          if (j = f_latom ! j = f_elmt)   cont; $ no elmt *
     139          if (j = f_ptuple)               cont; $ no packed tuple(*)
     140          if (is_fbase(j))                cont;
     141
     142          if is_fmap(j) then
     143              if ( ^ is_fbsd(j) & is_funt(ft_im(j))) cont;
     144          end if;
     145
     146          cl           = fsclass(j);
     147          ft_samp(j)   = blocklen(cl);
     148          blocklen(cl) = blocklen(cl) + 1;
     149      end do;
     150
     151$ add room at the end of the untyped block for a skip word.
stra  38      skip_offs = blocklen(scl_untyped);
stra  39      blocklen(scl_untyped) = blocklen(scl_untyped) + 1;
     154
     155$ assign origins to new blocks
stra  40      do cl = scl_min to scl_max;
     157          blockorg(cl) = sym_lim-1;   get_symtab(blocklen(cl));
     158      end do;
     159
     160$ adjust addresses and build run time names entries
     161
     162      do j = symtab_org+1 to symtabp;
     163          if (^ is_store(j)) cont;
     164
     165          org  = blockorg(sclass(j));
     166          addr = org - address(j);
     167
     168          address(j) = addr;
smfa  32          call iname('', j, addr);
     170
     171          $ we allocate two consecutive symbol table entries for each
     172          $ constant base:  initialise the second names entry
     173          if is_fbase(form(j)) & is_const(j) then
smfa  33              call iname('c$', j, addr-1);
     175          end if;
     176      end do;
     177
     178      do j = formtab_org+1 to formtabp;
     179          if (is_fbsd(j) & j <= f_max)    cont; $ no sample
     180          if (is_floc(j) & ft_pos(j) = 0) cont;
     181          if (j = f_latom ! j = f_elmt)   cont;
     182          if (j = f_ptuple)               cont;
     183
     184          if is_fmap(j) then
     185              if ( ^ is_fbsd(j) & is_funt(ft_im(j))) cont;
     186          end if;
     187
     188          if is_fbase(j) then $ use value as sample
     189              if (ft_samp(j) ^= 0) ft_samp(j) = address(ft_samp(j));
     190
     191          else
     192              org  = blockorg(fsclass(j));
     193              addr = org - ft_samp(j);
     194
     195              ft_samp(j) = addr;
smfa  34              call iname('.om', 0, addr);
     197
     198              if (j = f_pair) s_pair = addr; $ save address of std pair
     199          end if;
     200      end do;
     201
     202$ initialize the skip word
     203
stra  41      skip_addr = blockorg(scl_untyped) - skip_offs;
stra  42      skip_valu = blocklen(scl_untyped);
     206      build_spec(heap(skip_addr), t_skip, skip_valu);
stra  43      assert scl_min = scl_untyped;  $ make sure trick still works
smfa  36      call iname('', curunit, skip_addr);
     208
     209      if (q1sd_flag) call sdump;  $ dump tables
     210
     211
     212      end subr alloc;
       1 .=member initname
smfa  37      subr iname(s1, nam, addr);
smfa  38
smfa  39$ this routine initialises the run-time names table.
smfa  40
smfa  41      size s1(sds_sz);        $ prefix string to be used
smfa  42      size nam(ps);           $ q1 symbol table pointer
smfa  43      size addr(ps);          $ run-time symbol table address
smfa  44
smfa  45      size s2(sds_sz);        $ symbol name as sds string
smfa  46      size l1(ps), l2(ps);    $ respective lengths of strings
smfa  47      size len(ps);           $ length of string
smfa  48      size card(ps);          $ cardinality of run-time names tuple
smfa  49      size maxi(ps);          $ maximum index of run-time names tuple
smfa  50      size spec(hs);          $ temporary for setl specifier
smfa  51      size ss1(ssz);          $ string specifier for long char block
smfa  52      size ptr(ps);           $ pointer to long character block
smfa  53      size leng(ps);          $ length of string block
smfa  54      size word(ps);          $ pointer to current word long char block
smfa  55      size offs(ps);          $ offset in current word long char block
smfa  56      size j(ps);             $ loop index
smfa  57
smfa  58      size init(1);           $ flags initial entry
smfa  59      data init = yes;
smfa  60
smfa  61      access q1vars;          $ access global q1 variables.
smfa  62      access nscod;           $ access variables global to cod.
smfa  63
smfa  64
smfa  65      if init then            $ first entry to routine
smfa  66          init = no;
smfa  67
smfa  68          $ allocate the tuple to hold the run-time names.
smfa  69          get_heap(talloc(4), rnames);
smfa  70          htype(rnames) = h_tuple; hlink(rnames) = 0;
smfa  71          hform(rnames) = f_tuple;
smfa  72          is_hashok(rnames) = no; is_neltok(rnames) = yes;
smfa  73          maxindx(rnames) = 4; maxi = 4; nelt(rnames) = 0; card = 0;
smfa  74
smfa  75          $ allocate the zero'th string block.
smfa  76          build_ss(ss1, 0, 0, 0); leng = 0;
smfa  77          get_heap(lcalloc(0), ptr); lc_nwords(ptr) = lcalloc(0);
smfa  78          htype(ptr) = h_lstring; hlink(ptr) = 0;
smfa  79          ss_ptr(ss1) = ptr;
smfa  80          build_spec(spec, t_oistring, ss1); is_shared_ spec = yes;
smfa  81          do j = 0 to maxi; tcomp(rnames, j) = spec; end do;
smfa  82
smfa  83          word = ptr + hl_lchars; offs = chorg;
smfa  84      end if;
smfa  85
smfa  86      $ set scope flags, if appropriate.
smfa  87      if nam = curmemb then rn_memb(addr) = yes; end if;
smfa  88      if nam = currout then rn_proc(addr) = yes; end if;
smfa  89
smfa  90      l1 = slen s1;
smfa  91
smfa  92      $ get symbol name.
smfa  93      if nam ^= 0 then
smfa  94          if name(nam) ^= 0 then
smfa  95              s2 = namesds(name(nam));
smfa  96          else    $ an internal name.
smfa  97              if l1 = 0 then  $ store q1 symbol table index.
smfa  98                  rn_indx(addr) = 0; rn_offs(addr) = nam;
smfa  99                  return;
smfa 100              else    $ generate name here.
smfa 101                  s2 = 't$' .pad. 7; len = nam;
smfa 102                  do j = 7 to 3 by -1;
smfa 103                      .ch. j, s2 = charofdig(mod(len, 10));
smfa 104                      len = len / 10;
smfa 105                  end do;
smfa 106              end if;
smfa 107          end if;
smfa 108          l2 = slen s2;
smfa 109      else
smfa 110          l2 = 0;
smfa 111      end if;
smfa 112
smfa 113      len = l1 + l2;
smfa 114
smfa 115      if ss_len(ss1)+len > leng then
smfa 116          if card = maxi then
smfa 117              $ we will have to fix this some day.
smfa 118              call overfl('run-time names table');
smfa 119          end if;
smfa 120
smfa 121          $ allocate the next string block.
smfa 122          build_ss(ss1, 0, 0, 0);
smfa 123          leng = (sym_end-sym_org+1)*4;
smfa 124          if (leng > max_ic_len) leng = max_ic_len;
smfa 125          get_heap(lcalloc(leng), ptr); lc_nwords(ptr) = lcalloc(leng);
smfa 126          htype(ptr) = h_lstring; hlink(ptr) = 0;
smfa 127          ss_ptr(ss1) = ptr;
smfa 128          build_spec(spec, t_istring, ss1);
smfa 129          card = card + 1; nelt(rnames) = card;
smfa 130          tcomp(rnames, card) = spec;
smfa 131
smfa 132          word = ptr + hl_lchars; offs = chorg;
smfa 133      end if;
smfa 134
smfa 135      $ initialise the compressed string specifier for this entry.
smfa 136      rn_indx(addr) = card;
smfa 137      rn_offs(addr) = ss_len(ss1) + 1;
smfa 138      rn_len(addr)  = len;
smfa 139
smfa 140      $ update then run-time names string descriptor.
smfa 141      ss_len(ss1) = ss_len(ss1) + len;
smfa 142      value_ tcomp(rnames, card) = ss1;
smfa 143
smfa 144      do j = 1 to l1;
smfa 145          .f. offs, chsiz, heap(word) = .ch. j, s1;
smfa 146
smfa 147          if offs = chlst then
smfa 148              word = word + 1; offs = chorg;
smfa 149          else
smfa 150              offs = offs + chinc;
smfa 151          end if;
smfa 152      end do;
smfa 153
smfa 154      do j = 1 to l2;
smfa 155          .f. offs, chsiz, heap(word) = .ch. j, s2;
smfa 156
smfa 157          if offs = chlst then
smfa 158              word = word + 1; offs = chorg;
smfa 159          else
smfa 160              offs = offs + chinc;
smfa 161          end if;
smfa 162      end do;
smfa 163
smfa 164
smfa 165      end subr iname;
       1 .=member sclass
       2      fnct sclass(j);
       3
       4$ returns sclass of a symtab entry. see comments in subr alloc.
       5
       6$ we assign symtab entries a storage class based on whether they are
       7$ parameters and on whether they are typed or untyped. it is
       8$ possible to special case typed constants, and assign them
       9$ an sclass of sc_untyped, since they will never contain
      10$ pointers to the collectable part of the heap. this special
      11$ casing speeds up the garbage collector. however we omit it
      12$ for the moment since it also makes heap dumps slightly less
      13$ readable.
      14
stra  44      size sclass(ps);        $ code scl_xxx returned
      16
      17      size j(ps);  $ symtab pointer
      18
      19      size tp(ps);  $ ft_type
      20
      21      access q1vars;          $ access global q1 variables.
      22      access nscod;           $ access variables global to cod.
      23
      24
      25      if is_param(j) then        $ parameter block
stra  45         sclass = scl_param;
      27
      28      else
      29          tp = symtype(j);
      30
      31          if tp = f_uint ! tp = f_ureal then
stra  46              sclass = scl_untyped;
      33
      34          elseif is_stk(j) then
stra  47              sclass = scl_stacked;
      36
      37          else
stra  48              sclass = scl_static;
      39          end if;
      40      end if;
      41
      42
      43      end fnct sclass;
       1 .=member fsclass
       2      fnct fsclass(fm);
       3
       4$ this routine is similar to sclass, but decides where to allocate
       5$ the sample value for a given form.
       6
       7      size fm(ps);   $ a form
       8
stra  49      size fsclass(ps);       $ code scl_xxx returned
      10
      11      access q1vars;          $ access global q1 variables.
      12      access nscod;           $ access variables global to cod.
      13
      14      if fm = f_uint ! fm = f_ureal then  $ used untyped block
stra  50          fsclass = scl_untyped;
      16
      17      else
stra  51          fsclass = scl_static;
      19      end if;
      20
      21
      22      end fnct fsclass;
       1 .=member genint
       2      fnct genint(n);
       3
       4$ this routine allocates and initializes an integer constant.
       5$ it is called on the fly when one of the emission routines
       6$ discovers that the constant is necessary.
       7
       8$ we return a symbol table pointer to the integer.
       9
      10
      11      size n(ps);   $ value of integer
      12
      13      size genint(ps);        $ q2 symbol table pointer returned
      18
      19      access q1vars;          $ access global q1 variables.
      20      access nscod;           $ access variables global to cod.
      21
      22
      23      if n <= 9 then  $ use standard value
      24          genint = address(sym_zero + n);
      25          return;
      26      end if;
      27
      28$ otherwise build new entry
      29      get_symtab(1);   genint = sym_lim;
      30      build_spec(heap(genint), t_int, n);
smfa 166      call iname('', 0, genint);
      43
      44
      45      end fnct genint;
       1 .=member codegen
       2      subr codegen;
       3
       4$ this is the top routine for actual code generation. we begin
       5$ by calling an initialization routine which builds a data
       6$ block for the code we are about to emit, then iterate over the
       7$ program processing q1 instructions.
       8
       9      size opc(ps);           $ q2 opcode
      10      size addr(ps);          $ misc. address
      11      size n(ps);             $ counter
      12      size addr1(ps);         $ run-time address of a1
      13      size addr2(ps);         $ run-time address of a2
      14      size addr3(ps);         $ run-time address of a3
      15      size stmt_pending(1);   $ statement quadruple pending
      16
      17      size genint(ps);        $ allocates integer constant
      18
      19      access q1vars;          $ access global q1 variables.
      20      access nscod;           $ access variables global to cod.
      21
      22
      23      call initcode;
      24      stmt_pending = no;
      25
      26
      27      code_loop;              $ iterate over code
      28
      29          get_addr(addr_a1, a1);  $ get addresses of operands
      30          get_addr(addr_a2, a2);
      31          get_addr(addr_a3, a3);
      32
      33          go to case(class(op)) in cl_minimum to cl_maximum;
      34
      35      /case(cl_noop)/  $ noop
      36
      37          cont_loop;
      38
      39      /case(cl_simp)/
      40
      41      /case(cl_umin)/   $ unary minus
      42
      43      /case(cl_int)/   $ fix, top, bot
      44
      45      /case(cl_real)/         $ yield real
      46
      47      /case(cl_str)/    $ things yielding strings
      48
      49      /case(cl_bool)/         $ yield boolean
      50
      51      /case(cl_uset)/         $ yield set(*)
      52
      53      /case(cl_not)/          $ q1_not
      54
      55      /case(cl_rand)/   $ random
      56
      57      /case(cl_arb)/  $ arb
      58
      59
      60          opc = spec_op(op, fm2);
      61
      62          if opc = 0 then
      63              opc = std_op(op);
      64
      65              if nargs(now) >= 2 then
      66                  call typea2;
      67              else
      68                  addr_a2 = 0;
      69              end if;
      70
      71              if nargs(now) = 3 then
      72                  call typea3;
      73              else
      74                  addr_a3 = 0;
      75              end if;
      76          end if;
      77
      78          call em2(opc, addr_a1, addr_a2, addr_a3);
      79          cont_loop;
      80
      81
      82      /case(cl_lessf)/  $ lessf
      83
      84          call emlessf;
      85          cont_loop;
      86
      87      /case(cl_stmt)/  $ statement trace
      88
      89          cstmt_count = cstmt_count + 1;
      90          stmt_tot = stmt_tot + 1;
      91
      92          if (stmt_flag = 0) cont_loop;
      93
      94          if next(now) ^= 0 then
      95              opc = opcode(next(now));
      96              if (opc = q1_stmt) cont_loop;
      97              if opc = q1_goto ! opc = q1_exit ! opc = q1_stop then
      98                  stmt_pending = yes;
      99                  cont_loop;
     100              end if;
     101          else    $ next(now) = 0, i.e. the end of a basic block
     102              stmt_pending = yes;
     103              cont_loop;
     104          end if;
     105
     106          call em2(q2_stmt, address(currout), stmt_count, cstmt_count);
     107          stmt_pending = no;
     108
     109          cont_loop;
     110
     111
     112      /case(cl_call)/    $ calls
     113
     114          if is_bip(a1) then  $ call to built in procedure
     115              get_addr(addr, symval(a1));  $ temp used for result
     116
     117              call em2(bip_op(a1), addr, addr_a1, addr_a2);
     118
     119          else
     120              if back_flag then
     121                  opc = q2_bcall;
     122              else
     123                  opc = q2_call;
     124              end if;
     125
     126              call em2(opc, labval(a1), addr_a1, addr_a2);
     127              call uselab(a1);
     128
     129              if (stmt_flag < 2) cont_loop;
     130              if next(now) ^= 0 then
     131                  if (opcode(next(now)) = q1_stmt) cont_loop;
     132              end if;
     133              call em2(q2_stmt,address(currout),stmt_count,cstmt_count);
     134              call sa4(yes);
     135          end if;
     136
     137          cont_loop;
     138
     139      /case(cl_goto)/   $ goto
     140
     141          call em2(q2_goto, labval(a1), 0, 0);
     142          call uselab(a1);
     143
     144          cont_loop;
     145
     146
     147      /case(cl_ifgo)/    $ conditional branches
     148
     149          if op = q1_if then
     150              opc = q2_gotrue;
     151          else
     152              opc = q2_gofalse;
     153          end if;
     154
     155          call em2(opc, labval(a2), addr_a1, 0);
     156          call uselab(a2);
     157
     158          cont_loop;
     159
     160      /case(cl_ifgo1)/   $ branches on binary predicate
     161
     162          if op = q1_ifeq ! op = q1_ifne then
     163              call spec_eq(opc, addr1, addr2, op, a1, a2);
     164
     165          elseif op = q1_ifin ! op = q1_ifnin then
     166              call spec_in(opc, addr1, addr2, op, a1, a2);
     167
     168          else
     169              call spec_pred(opc, addr1, addr2, op, a1, a2);
     170          end if;
     171
     172          call em2(opc, labval(a3), addr1, addr2);
     173          call uselab(a3);
     174
     175          cont_loop;
     176
     177      /case(cl_case)/   $ case jump
     178
     179
     180          call typea2;
     181
     182          opc = spec_op(op, fm1);
     183          call em2(opc, addr_a1, addr_a2, 0);
     184          cont_loop;
     185
     186
     187      /case(cl_lab)/          $ label
     188
     189          call setlab(a1);
     190
     191          if (asm_flag) call em2(std_op(op), labval(a1), 0, 0);
     192
     193          if (stmt_flag = 0) cont_loop;
     194
     195          if next(now) ^= 0 then
     196              if (opcode(next(now)) = q1_stmt) cont_loop;
     197          end if;
     198
     199          if stmt_pending then
     200              call em2(q2_stmt,address(currout),stmt_count,cstmt_count);
     201              stmt_pending = no;
     202          end if;
     203
     204          cont_loop;
     205
     206      /case(cl_entry)/       $ routine entry
     207
     208          cstmt_count = estmt_count;
     209          if ^ asm_flag then
     210              call em2(q2_stmt,address(currout),stmt_count,cstmt_count);
     211          end if;
     212          stmt_tot = stmt_tot + 1;
     213
     214          if back_flag then
     215              call embentry;
     216          else
     217              call ementry;
     218          end if;
     219
     220          cont_loop;
     221
     222      /case(cl_exit)/         $ routine exit
     223
     224          if back_flag then
     225              call embexit;
     226          else
     227              call emexit;
     228          end if;
     229
     230          cont_loop;
     231
     232
     233      /case(cl_min)/          $ binary operators min, max
     234
     235      /case(cl_bin)/          $ binary operations +, -, *, /, and mod
     236
     237          call embin;
     238          cont_loop;
     239
     240
     241      /case(cl_with)/         $ with and less
     242
     243          call emwith;
     244          cont_loop;
     245
     246      /case(cl_from)/         $ from
     247
     248          call emfrom;
     249          cont_loop;
     250
     251      /case(cl_pred1)/        $ membership tests
     252
     253          call spec_in(opc, addr2, addr3, op, a2, a3);
     254          call em2(opc, addr_a1, addr2, addr3);
     255          cont_loop;
     256
     257      /case(cl_pred2)/        $ binary predicates
     258
     259          if op = q1_eq ! op = q1_ne then
     260              call spec_eq(opc, addr2, addr3, op, a2, a3);
     261
     262          else
     263              call spec_pred(opc, addr2, addr3, op, a2, a3);
     264          end if;
     265
     266          call em2(opc, addr_a1, addr2, addr3);
     267          cont_loop;
     268
     269
     270      /case(cl_asrt)/         $ test program assertion
     271
smfb 140          if op = q1_ifasrt then
smfb 141              call em2(q2_ifasrt, labval(a1), 0, 0);
smfb 142              call uselab(a1);
smfb 143              cont_loop;
smfb 144          end if;
smfb 145
     272          if ^ can_assign(f_atom, fm1) then
     273              call emconv(sym_t1_, a1, f_atom, no);
     274              addr_a1 = addr_t1;
     275          end if;
     276
     277          call em2(q2_asrt, addr_a1, address(currout), stmt_count);
     278          cont_loop;
     279
     280      /case(cl_nelt)/         $ nelt
     281
     282          call emnelt;
     283          cont_loop;
     284
     285      /case(cl_newat)/        $ newat
     286
     287          call emnewat;
     288          cont_loop;
     289
     290      /case(cl_of)/           $ y := f(x)
     291
     292          call emof;
     293          cont_loop;
     294
     295      /case(cl_ofa)/          $ y := f<>
     296
     297          call emofa;
     298          cont_loop;
     299
     300      /case(cl_subst)/        $ y := s(i..j)
     301
     302          call emsubst;
     303          cont_loop;
     304
     305      /case(cl_sof)/          $ f(x) := y
     306
     307          call emsof;
     308          cont_loop;
     309
     310      /case(cl_sofa)/         $ f<> := y
     311
     312          call emsofa;
     313          cont_loop;
     314
     315      /case(cl_ssubst)/       $ s(i..j) := y
     316
     317          call emssubst;
     318          cont_loop;
     319
     320      /case(cl_argin)/        $ procedure argument
     321
     322          call emargin;
     323          cont_loop;
     324
     325      /case(cl_push)/         $ stack push
     326
     327$ push a1, converting it to the element type of the set or tuple
     328          call empush(a1, elmt_type(fm2));
     329
     330          cont_loop;
     331
     332      /case(cl_free)/
     333
     334          n = 0;
     335          while 1;
     336              n = n + 1;
     337              $ if we pushed an untyped value, we must pop a skip word
     338              if (is_funt(arg_type(a2, symval(a3)))) n = n + 1;
     339
     340              if (next(now) = 0) quit while;
     341              if (class(opcode(next(now))) ^= cl_free) quit while;
     342              prev = now; now = next(now);
     343          end while;
     344
     345          addr = genint(n);
     346
     347          if back_flag & ^ is_bip(a2) then
     348              call em2(q2_bfree, addr, 0, 0);
     349          elseif n = 1 then
     350              call em2(q2_free1, 0, 0, 0);
     351          else
     352              call em2(q2_free, addr, 0, 0);
     353          end if;
     354
     355          cont_loop;
     356
     357
     358      /case(cl_argout)/       $ argout
     359
     360          call emargout;
     361          cont_loop;
     362
     363
     364      /case(cl_asn)/          $ x := y
     365
     366          call emasn;
     367          cont_loop;
     368
     369
     370      /case(cl_st)/           $ enumerative set/tuple former
     371
     372          call emst;
     373          cont_loop;
     374
     375      /case(cl_st1)/          $ iterative set/tuple former
     376
     377          call emst1;
     378          cont_loop;
     379
     380      /case(cl_st2)/          $ q1_dom and q1_range
     381
     382          call emst2;
     383          cont_loop;
     384
     385
     386      /case(cl_debug)/        $ debugging options
     387
     388          call emdebug;
     389          cont_loop;
     390
     391      /case(cl_next)/
     392
     393      /case(cl_nextd)/
     394
     395          if (^ can_assign(fm3, deref_typ(fm3))) call ermsg(3, a3);
     396
     397          opc = spec_op(op, fm3);
     398          if (opc = 0) opc = std_op(op);
     399
smfb 146          call set_a1;        $ copy_flag might be set for next on maps
     400          call em2(opc, addr_a1, addr_a2, addr_a3);
     401          cont_loop;
     402
     403      /case(cl_ok)/
     404
     405          call emok;
     406          cont_loop;
     407
     408      /case(cl_fail)/
     409
     410          call emfail;
     411          cont_loop;
     412
     413      /case(cl_succeed)/
     414
     415          call emsucceed;
     416          cont_loop;
     417
     418
     419      end_loop;
     420
     421      call termcode;  $ finish off code block
     422
     423
     424      end subr codegen;
       1 .=member speceq
       2      subr spec_eq(opc, addr1, addr2, op1, in1, in2);
       3
       4$ this routine special cases equality tests. its inputs are:
       5
       6$ op1:      q1 opcode
       7$ in1:      symtab pointer for first input
       8$ in2:      symtab pointer for second input
       9
      10$ its outputs are:
      11
      12$ opc:      q2 opcode
      13$ addr1:    address of first input
      14$ addr2:    address of second input
      15
      16$ it is fairly likely that in2 is a constant. we do two types of special
      17$ casing here:
      18
      19$ first, we look for an alternate representation of in2 which has the
      20$ same type as in1. this may allow us to do an inline test.
      21
      22$ second, we see whether in2 is a constant such as .nl or .om
      23$ if so, we use a special equality test.
      24
      25$ if in2 is not one of the special constants we choose a q2 opcode
      26$ based on the types of in1 and in2. if this winds up being a
      27$ a library call we generate conversions to make sure that
      28$ in1 and in2 are not untyped.
      29
      30      size op1(ps),   $ q1 opcode
      31           in1(ps),   $ first input
      32           in2(ps);   $ second input
      33
      34      size opc(ps),    $ q2 opcode
      35           addr1(ps),  $ address for in1
      36           addr2(ps);  $ address for in2
      37
smfb 147      size f1(ps), f2(ps);    $ forms of inputs
smfb 148      size t1(ps), t2(ps);    $ form types of inputs
      40
      41      access q1vars;          $ access global q1 variables.
      42      access nscod;           $ access variables global to cod.
      43
      44$ get addresses and find matching repr for in2
      45      get_addr(addr1, in1);
      46      get_addr(addr2, in2);
      47
      48      call match_repr(addr2, in2, form(in1));
smfb 149      call match_repr(addr1, in1, form(in2));
smfb 150
smfb 151      f1 = form(in1); t1 = ft_type(f1);
smfb 152      f2 = form(in2); t2 = ft_type(f2);
      49
      50      if (in2 = sym_om   ) go to special;
      55      if (in2 = sym_true ) go to special;
      56      if (in2 = sym_false) go to special;
      57
smfb 153      if (is_fint(f1) & is_fint(f2)) go to special;
smfb 154      if (is_ftup(f1) & is_ftup(f2)) go to special;
smfb 155      if (is_fset(f1) & is_fset(f2)) go to special;
      61
smfb 156      if t1 = f_elmt & t2 = f_elmt & ft_base(f1) = ft_base(f2) then
      65          $ both inputs are elements of the same base:  check
      66          $ pointer equality instead of value equality.
      67          if     op1 = q1_eq   then opc = q2_eqv;   return;
      68          elseif op1 = q1_ne   then opc = q2_nev;   return;
      69          elseif op1 = q1_ifeq then opc = q2_goeqv; return;
      70          elseif op1 = q1_ifne then opc = q2_gonev; return;
      71          end if;
      72      end if;
      73
      74      go to standard;
      75
      76
      77
      78
      79/special/    $ look for special case
      80
smfb 157      if in2 <= sym_maximum & is_funt(f1) = 0 & is_funt(f2) = 0 then
smfb 158          $ may be system constant.  note that since we do not include
smfb 159          $ type information into the tests which follow we must exclude
smfb 160          $ untyped data.
      82
      83          if op1 = q1_eq then
      84              opc = eqop(in2);
      85
      86          elseif op1 = q1_ne then
      87              opc = neop(in2);
      88
      89          elseif op1 = q1_ifeq then
      90              opc = ifeq_op(in2);
      91
      92          else
      93              opc = ifne_op(in2);
      94          end if;
      95
      96          if opc ^= 0 then addr2 = 0; return; end if;
      97      end if;
      98
smfb 161      if t1 = t2 then
smfb 162          opc = spec_op(op, t1);   if (opc ^= 0) return;
smfb 163      end if;
     101
     102/standard/      $ use standard op1ode
     103
     104      opc = std_op(op);
     105
     106      if is_funt(form(in1)) then
     107          call emconv(sym_t1_, in1, f_gen, no);
     108          addr1 = addr_t1;
     109      end if;
     110
     111      if is_funt(form(in2)) then
     112          call emconv(sym_t2_, in2, f_gen, no);
     113          addr2 = addr_t2;
     114      end if;
     115
     116      return;
     117
     118      end subr spec_eq;
       1 .=member specin
       2      subr spec_in(opc, addr1, addr2, op1, in1, in2);
       3
       4$ this routine special cases membership tests. its inputs are:
       5
       6$ op1:      q1 opcode
       7$ in1:      symtab pointer for first input
       8$ in2:      symtab pointer for second input
       9
      10$ its outputs are:
      11
      12$ opc:      q2 opcode
      13$ addr1:    address of first input
      14$ addr2:    address of second input
      15
      16$ if in1 is a constant we try to find a representation of it
      17$ with the element type of in2.
      18
      19
      20      size op1(ps),   $ q1 opcode
      21           in1(ps),   $ first input
      22           in2(ps);   $ second input
      23
      24      size opc(ps),    $ q2 opcode
      25           addr1(ps),  $ address for in1
      26           addr2(ps);  $ address for in2
      27
      28      size f1(ps);            $ form of element
      29      size f2(ps);            $ form of string/tuple/set/map
      30      size n1(ps);            $ number of dereferences for element
      31      size t2(ps);            $ element form of second operand
      32
      33      access q1vars;          $ access global q1 variables.
      34      access nscod;           $ access variables global to cod.
      35
      36$ get addresses and find matching repr for in2
      37      get_addr(addr1, in1);
      38      get_addr(addr2, in2);
      39
smfb 164      call match_repr(addr1, in1, elmt_type(ft_deref(form(in2))));
      41
      42      f1 = form(in1);   n1 = 0;
      43      f2 = deref_typ(form(in2));
      44
      45      t2 = elmt_type(f2);
      46
      47      while ft_type(f1) = f_elmt & f1 ^= t2;
      48          f1 = ft_elmt(ft_base(f1));   n1 = n1 + 1;
      49      end while;
      50
      51      if (f1 ^= t2) go to standard;
      52
      53      opc = spec_op(op1, f2);   if (opc = 0) go to standard;
      54
      55      if n1 = 1 then
      56          call em2(q2_deref1, addr_t1, addr1,  0);
      57          addr1 = addr_t1;
      58      elseif n1 > 1 then
      59          call em2(q2_deref,  addr_t1, addr1, n1);
      60          addr1 = addr_t1;
      61      end if;
      62
      63      if f2 ^= form(in2) then
      64          call emconv(sym_t2_, in2, f2, no);   addr2 = addr_t2;
      65      end if;
      66
      67      return;
      68
      69
      70/standard/      $ use standard op1ode
      71
      72      opc = std_op(op);
      73
      74      if is_funt(f1) then
      75          call emconv(sym_t1_, in1, f_gen, no);
      76          addr1 = addr_t1;
      77      end if;
      78
      79      return;
      80
      81      end subr spec_in;
       1 .=member specpred
       2      subr spec_pred(opc, addr1, addr2, op1, in1, in2);
       3
       4$ this routine special cases binary predicates such as <, >, etc.
       5$ where it is desirable for the two inputs to have the same repr.
       6$ the inputs to the routine are:
       7
       8$ op1:      q1 opcode
       9$ in1:      symtab pointer for first input
      10$ in2:      symtab pointer for second input
      11
      12$ its outputs are:
      13
      14$ opc:      q2 opcode
      15$ addr1:    address of first input
      16$ addr2:    address of second input
      17
      18$ if in2 is a constant we look for a representation of it with
      19$ the same repr as in1.
      20
      21
      22      size op1(ps),   $ q1 opcode
      23           in1(ps),   $ first input
      24           in2(ps);   $ second input
      25
      26      size opc(ps),    $ q2 opcode
      27           addr1(ps),  $ address for in1
      28           addr2(ps);  $ address for in2
      29
      30      size t1(ps),  $ types of inputs
      31           t2(ps);
      32
      33      access q1vars;          $ access global q1 variables.
      34      access nscod;           $ access variables global to cod.
      35
      36$ get addresses and find matching repr for in2
      37      get_addr(addr1, in1);
      38      get_addr(addr2, in2);
      39
      40      call match_repr(addr2, in2, form(in1));
smfb 165      call match_repr(addr1, in1, form(in2));
      41
      42      t1 = form(in1);
      43      t2 = form(in2);
      44
      45      if t1 = t2 then
      46          opc = spec_op(op1, t2);
      47          if (opc ^= 0) return;
      48      end if;
      49
      50/standard/      $ use standard op1ode
      51
      52      opc = std_op(op);
      53
      54      if is_funt(t1) then
      55          call emconv(sym_t1_, in1, f_gen, no);
      56          addr1 = addr_t1;
      57      end if;
      58
      59      if is_funt(t2) then
      60          call emconv(sym_t2_, in2, f_gen, no);
      61          addr2 = addr_t2;
      62      end if;
      63
      64      return;
      65
      66      end subr spec_pred;
       1 .=member ementry
       2      subr ementry;
       3
       4$ this routine emits code for procedure entries. this is
       5$ done in three steps:
       6
       7$ 1. call setlab to perform relocation.
       8
       9$ 2. if we plan to generate assembly code then set the value of the
      10$    procedure to point to the code block and emit a q2_entry or
      11$    q2_mentry instruction.
      12
      13$ 3. emit a series of move instructions. these instructions depend
      14$    on whether the routine is recursive or not. if the routine
      15$    is recursive emit:
      16
      17$    a. q2_swap    swap the new values of the formal parameters,
      18$                  which are now in the stack, with the old values,
      19$                  which are now in the symbol table. this saves
      20$                  their old values.
      21
      22$    b. q2_savel   get a stack block and save all the local stacked
      23$                  variables and temporaries.
      24
      25$    otherwise emit:
      26
      27$    a. q2_loadp   copy the new values of the parameters into
      28$                  the symbol table
      29
      30$ 4. emit code to initialize all stacked local variables.
      31$    note that we do not initialize temporaries since they
      32$    never be used before they are defined.
      33
      34
      35
      36      size j(ps),  $ loop index
      37           fm(ps);    $ form
      38
      39      access q1vars;          $ access global q1 variables.
      40      access nscod;           $ access variables global to cod.
      41
      42      call setlab(currout);   $ relocate entry point
      43
      44      if asm_flag then
      45          value(address(currout)) = labval(currout);
      46
      47          if currout = sym_main_ then
      48              call em2(q2_mentry, 0, 0, 0);
      49          else
      50              call em2(q2_pentry, labval(currout), 0, 0);
      51          end if;
      52      end if;
      53
      54
      55$ emit appropriate move instructions, depending on whether routine
      56$ is recursive.
      57
      58      if is_rec(currout) then    $ recursive case
stra  52          call emmove(q2_swap,  scl_param);
stra  53          call emmove(q2_savel, scl_stacked);
      61
      62      else  $ non recursive
stra  54          call emmove(q2_loadp, scl_param);
      64      end if;
      65
      66$ emit code to initialize stacked variables
      67      do j = symtab_org+1 to symtabp;
      68          if (^ is_store(j) ! is_temp(j) ) cont;
      69          if (^ is_stk(j)   ! is_param(j)) cont;
      70
      71          if (is_internal(j)) cont; $ ishadow variable
      72
      73          fm = form(j);
      74          call em2(q2_asn, address(j), ft_samp(fm), 0);
      75      end do;
      76
      77
      78      end subr ementry;
       1 .=member emexit
       2      subr emexit;
       3
       4$ this routine emits the code for an exit block. this consists of two
       5$ things:
       6
       7$ 1. a series of move instructions. if the routine is recursive
       8$    we emit:
       9
      10$    a. q2_resetl    move the old values of the stacked local
      11$                    variables back to the symbol table and free
      12$                    the stack space used to save them.
      13
      14$    b. q2_swap     restore parameters
      15
      16$    otherwise we emit:
      17
      18$    a. q2_clearl    set all local stacked variables to zero, thus
      19$                    freeing the data blocks they point to.
      20
      21
      22$    b. q2_resetp   restore parameters
      23
      24$ 2. if this is the main program emit a stop instruction; otherwise
      25$    emit a return.
      26
      27      access q1vars;          $ access global q1 variables.
      28      access nscod;           $ access variables global to cod.
      29
      30      if is_rec(currout) then
stra  55          call emmove(q2_resetl, scl_stacked);
stra  56          call emmove(q2_swap,   scl_param);
      33      else
stra  57          call emmove(q2_clearl, scl_stacked);
stra  58          call emmove(q2_resetp, scl_param);
      36      end if;
      37
      38$ emit stop or return
      39      if a1 = sym_main_ then
      40          call em2(q2_stop, 0, 0, 0);
      41      else
      42          call em2(q2_retn, 0, 0, 0);
      43      end if;
      44
      45
      46      end subr emexit;
       1 .=member embentry
       2      subr embentry;
       3
       4$ this routine emits code for procedure entries when backtracking
       5$ is enabled. this code consists of:
       6
       7$    entry instruction
       8$    branch to body
       9
      10$    dexit, undo, and fail2 instructions
      11
      12$    body
      13
      14$ the q2_entry instruction has the following arguments:
      15
      16$ a1:    address of 0-th parameter
      17$ a2:    length of parameter block
      18$ a3:    address of 0-th local variable
      19$ a4:    length of local variables block
      20$ a5:    address of dexit instruction
      21
      22      size xa1(ps),     $ a1
      23           xa2(ps),     $ a2
      24           xa3(ps),     $ a3
      25           xa4(ps),     $ a4
      26           xa5(ps);
      27
      28      size p1(ps);            $ code pointers
      29      size p2(ps);
      30      size dexit_addr(ps);    $ address of q2_dexit instruction
      31      size addr(ps);          $ run-time address of backtracked variable
      32      size n(ps);             $ number of saved variables
      33      size j(ps);             $ loop index
      34
      35      access q1vars;          $ access global q1 variables.
      36      access nscod;           $ access variables global to cod.
      37
      38      call setlab(currout);   $ do label relocation
      39
      40      if asm_flag then
      41          value(address(currout)) = labval(currout);
      42
      43          if currout = sym_main_ then
      44              call em2(q2_mentry, 0, 0, 0);
      45          else
      46              call em2(q2_pentry, labval(currout), 0, 0);
      47          end if;
      48      end if;
      49
stra  59      xa1 = blockorg(scl_param) - (blocklen(scl_param)-1);
stra  60      xa2 = blocklen(scl_param);
stra  61      xa3 = blockorg(scl_stacked) - (blocklen(scl_stacked)-1);
stra  62      xa4 = blocklen(scl_stacked);
      54      xa5 = codep + 4 * inst_nw;
      55
      56      call em2(q2_entry, xa5, xa1, xa2);
      57      call em2(q2_noop,  xa3, xa4,   0);
      58
      59$ emit goto and save a pointer to it so we can fill in its argument late
      60      call em2(q2_goto, 0, 0, 0);
      61      p1 = codep;
      62
      63$ emit dexit instruction. this has four arguments which are the same
      64$ as the first four arguments of the entry instruction.
      65
      66      dexit_addr = codep + inst_nw;
      67      if (asm_flag) call em2(q2_lab, dexit_addr, 0, 0);
      68
      69      call em2(q2_dexit, xa1, xa2, xa3);
      70      call em2(q2_noop,  xa4,   0,   0);
      71
      72$ set global pointer to 'undo' instruction. this address is needed as
      73$ an argument to the q2_exit instruction.
      74
      75      undo_addr = codep + inst_nw;
      76      if (asm_flag) call em2(q2_lab, undo_addr, 0, 0);
      77
      78$ emit the 'undo' instruction with the usual four arguments then
      79$ set a5 to point back to the 'dexit' instruction.
      80
      81      xa5 = dexit_addr;
      82      call em2(q2_undo,  xa5, xa1, xa2);
      83      call em2(q2_noop,  xa3, xa4,   0);
      84
      85$ set global pointer to q2_fail instruction. this is needed as an
      86$ argument to q2_ok instruction.
      87
      88      fail2_addr = codep + inst_nw;
      89      if (asm_flag) call em2(q2_lab, fail2_addr, 0, 0);
      90
      91$ emit 'fail2' instruction. this instruction has one argument
      92$ which gives the number of variables being saved, and is followed
      93$ by a series of noops containing the addresses of the saved
      94$ variables.
      95
      96      call em2(q2_fail2, 0, 0, 0);
      97
      98      n  = 0;    $ number of saved variables
      99      p2 = codep;
     100
     101      do j = 1 to symtabp;
     102          if (^ is_back(j)) cont;
     103
     104          n = n + 1;
     105
     106          get_addr(addr, j);
     107          call em2(q2_noop, addr, 0, 0);
     108      end do;
     109
     110      codea2(p2) = n;
     111
     112$ fill in address of body in the goto instruction
     113      p2 = codep + inst_nw;
     114      codea1(p1) = p2;
     115      if (asm_flag) call em2(q2_lab, p2, 0, 0);
     116
     117
     118      end subr embentry;
       1 .=member embexit
       2      subr embexit;
       3
       4$ this routine emits procedure exits when backtracking is enabled. this
       5$ consists of a single q2_exit instruction with:
       6
       7$ a1:    address of 0-th parameter
       8$ a2:    length of parameter block
       9$ a3:    address of 0-th local variable
      10$ a4:    length of local variables block
      11$ a5:    address of undo instruction
      12
      13      size xa1(ps),     $ a1
      14           xa2(ps),     $ a2
      15           xa3(ps),     $ a3
      16           xa4(ps),     $ a4
      17           xa5(ps);
      18
      19      access q1vars;          $ access global q1 variables.
      20      access nscod;           $ access variables global to cod.
      21
      22$ if this is the main program, simply emit a 'stop' instruction.
      23
      24      if a1 = sym_main_ then
      25          call em2(q2_stop, 0, 0, 0);
      26          return;
      27      end if;
      28
      29$ otherwise emit 'exit' instruction.
      30
stra  63      xa1 = blockorg(scl_param) - (blocklen(scl_param)-1);
stra  64      xa2 = blocklen(scl_param);
stra  65      xa3 = blockorg(scl_stacked) - (blocklen(scl_stacked)-1);
stra  66      xa4 = blocklen(scl_stacked);
      35      xa5 = undo_addr;
      36
      37      call em2(q2_exit,  xa5, xa1, xa2);
      38      call em2(q2_noop,  xa3, xa4,   0);
      39
      40
      41      end subr embexit;
       1 .=member emok
       2      subr emok;
       3
       4$ this routine emits the code for 'ok'. this constist of a q2_ok
       5$ instruction with:
       6
       7$ a1:     address of q2_fail2 instruction
       8$ a2:     number of saved variables
       9
      10$ this is followed by a series of q2_noop instructions with:
      11
      12$ a1:    address of saved variable
      13
      14      size p(ps),    $ code pointer
      15           addr(ps), $ address
      16           j(ps),    $ loop index
      17           n(ps);    $ number of saves variabled
      18
      19      access q1vars;          $ access global q1 variables.
      20      access nscod;           $ access variables global to cod.
      21
      22      call em2(q2_ok, fail2_addr, 0, 0);
      23
      24      n = 0;
      25      p = codep;
      26
      27      do j = 1 to symtabp;
      28          if (^ is_back(j)) cont;
      29
      30          n = n + 1;
      31
      32          get_addr(addr, j);
      33          call em2(q2_noop, addr, 0, 0);
      34      end do;
      35
      36      codea2(p) = n;
      37
      38
      39      end subr emok;
       1 .=member emfail
       2      subr emfail;
       3
       4$ this routine emits the code for 'fail'
       5
       6      call em2(q2_fail1, 0, 0, 0);
       7
       8      end subr emfail;
       1 .=member emsucceed
       2      subr emsucceed;
       3
       4$ this routine emits the code for 'succeed'.
       5
       6      call em2(q2_succeed, 0, 0, 0);
       7
       8      end subr emsucceed;
       1 .=member emmove
       2      subr emmove(opc, cl);
       3
       4$ this routine emits various move instructions as part of routine
       5$ prologues and epilogs. these instructions all have:
       6
       7$ a1:  address of first word of block
       8$ a2:  length of block
       9$ a3:  unused(zero)
      10$
      11$ n.b. symbols are allocated from high-address to low-address.  hence
      12$ 'blockorg' points to the high-address of the block.  we adjust here
      13$ so that the first argument of the move instruction points to the
      14$ lowest-address word to be moved.
      15
      16
      17      size opc(ps),   $ opcode for move
      18           cl(ps);  $ storage class being moved
      19
      20      size addr(ps),   $ starting address of block
      21           len(ps);  $ length of block
      22
      23      access q1vars;          $ access global q1 variables.
      24      access nscod;           $ access variables global to cod.
      25
      26
      27      addr = blockorg(cl) - (blocklen(cl)-1);
      28      len = blocklen(cl);
      29
      30      if (len ^= 0) call em2(opc, addr, len, 0);
      31
      32
      33      end subr emmove;
       1 .=member embin
       2      subr embin;
       3
       4$ this routine emits the standard binary operators, namely +, -,
       5$ *, /, and mod.
       6
       7      size opc(ps);  $ q2 opcode
smfb 166
smfb 167      size ok_conv(1);        $ checks for legal conversions
       8
       9      access q1vars;          $ access global q1 variables.
      10      access nscod;           $ access variables global to cod.
      11
      12$ we begin by checking whether we are calling a general library
      13$ routine. if so, we will not emit any copy instructions, but will
      14$ pass 'cflag' onto the library.
      15
      16      opc = spec_op(op, fm1);
      17$
      18$ for sets we require that a1 and a2 have the same repr and that a3
      19$ have a similar repr.
      20$
      21$ note that operations yielding local objects always have the form
      22$ 'a := a <*binop> b'.  if b is not local we must convert both 'a'
      23$ and to set(*), perform the operation and convert the result back.
      24$
      25      if is_fset(fm1) then
      26          if is_floc(fm1) & ^ similar_repr(fm1, fm3) then
      27              call set_a2(f_uset, yes);   call set_a3(f_uset, yes);
      28
      29              opc = spec_op(op, f_uset);
      30              if (opc = 0) opc = std_op(op);
      31
      32              call em2(opc,  addr_t1,  addr_a2,  addr_a3);
      33
      34              form(sym_t1_) = f_uset;
      35              call emconv(a1,  sym_t1_,  fm1, no);
      36              form(sym_t1_) = f_gen;
      37
suna  37          elseif ok_conv(fm1, fm3) ! op = q1_add then
suna  38              call set_a2(fm1, yes); call set_a3(fm1, yes);
suna  39              if (opc = 0) opc = std_op(op);
suna  40              call em2(opc, addr_a1, addr_a2, addr_a3);
suna  41
suna  42          else
suna  43              call set_a2(f_uset, yes); call set_a3(f_uset, yes);
suna  44              opc = spec_op(op, f_uset);
suna  45              if (opc = 0) opc = std_op(op);
suna  46              call em2(opc, addr_t1, addr_a2, addr_a3);
suna  47              form(sym_t1_) = f_uset;
suna  48              call emconv(a1, sym_t1_, fm1, no);
suna  49              form(sym_t1_) = f_gen;
      42          end if;
      43
      44      elseif opc = 0 then     $ general case
      45          $ if the first input is a local object which might have to
      46          $ be copied, we first convert it to a f_uset.
      47          if is_floc(fm2) & cflag(now) ^= copy_no then
      48              call set_a2(f_uset, yes);
      49          else
      50              call typea2;    $ make sure the input is typed
      51          end if;
      52
      53          call typea3;
      54
      55          call em2(std_op(op), addr_a1, addr_a2, addr_a3);
      56          call sa4(cflag(now));
      57
      58      else   $ special case. emit conversions and copies.
      59          $ special case 'i +:= 1' on short and untyped ints
      60          if opc = q2_addi & a1 = a2 & a3 = sym_one then
      61              opc = q2_inci;   addr_a2 = 0;   addr_a3 = 0;
      62          elseif opc = q2_addui & a1 = a2 & a3 = sym_one then
      63              opc = q2_incui;  addr_a2 = 0;   addr_a3 = 0;
      64          else
      65              if (opc = q2_addstr) cflag(now) = copy_yes;
      66              call set_a2(fm1, no);   call set_a3(fm1, no);
      67          end if;
      68
      69          call em2(opc, addr_a1, addr_a2, addr_a3);
      70      end if;
      71
      72
      73      end subr embin;
       1 .=member emwith
       2      subr emwith;
       3
       4$ this routine emits code for the setl 'with' and 'less' operators.
       5$ there are two possibilities:
       6
       7$ 1. we are doing a simple case, such as the statement 's with x'.
       8$    in this case a1 = a2.
       9
      10$ 2. we are doing one of the more complex cases, i.e. 's1 := s with x'
      11$    or 'f(x) with y'. in both these cases the a1 is an internal
      12$    variable with type general.
      13
      14$ n.b. we call 'set_a3' before 'set_a2' in order to assure proper
      15$      share bit setting at run time.
      16
      17
      18      size opc(ps);           $ q2 opcode
      19      size fm(ps);            $ dereferenced form of a2
smfb 174
smfb 175      size ok_conv(1);        $ checks for legal conversions
      20
      21      access q1vars;          $ access global q1 variables.
      22      access nscod;           $ access variables global to cod.
      23
      24
      25      if is_pre(op) then
      26          fm = deref_typ(fm1);
      27
      28      elseif is_floc(fm2) & a1 ^= a2 then
      29          fm = f_uset;
      30      else
      31          fm = deref_typ(fm2);
      32      end if;
      36
      37      opc = spec_op(op, fm);
smfb 176
smfb 177      if is_pre(op) ! ok_conv(elmt_type(fm), fm3) then
smfb 178          call set_a3(elmt_type(fm), no);
smfb 179      else
smfb 180          opc = 0;
smfb 181      end if;
smfb 182
smfb 183      call set_a2(fm, yes);
      38
      39      if opc = 0 ! (op = q1_with & ft_type(fm) = f_mtuple) then
      40          opc = std_op(op);
      41      end if;
      42
      43      if can_assign(fm1, fm) then
      44          call em2(opc, addr_a1, addr_a2, addr_a3);
      45
      46      else
      47          form(sym_t1_) = fm;
      48          call em2(opc, addr_t1, addr_a2, addr_a3);
      49          call emconv(a1, sym_t1_, fm1, no);
      50          form(sym_t1_) = f_gen;
      51      end if;
      52
      53
      54      end subr emwith;
       1 .=member emfrom
       2      subr emfrom;
       3
       4$ this routine emits code for 'a1 from a2'. if does not have
       5$ the same type as the elements of a2 then we emit
       6$ 't1_ from a2; a1 = t1_' and convert on the assignment.
       7
       8
       9      size opc(ps);           $ q2 opcode
      10      size fm(ps);            $ element form of a2
      11
      12      access q1vars;          $ access global q1 variables.
      13      access nscod;           $ access variables global to cod.
      14
      15
      16      fm = elmt_type(fm2);
      17
      18      opc = spec_op(op, fm2);
      19
      20      if opc ^= 0 then
      21          if cflag(now) = copy_yes then
      22              call em2(q2_copy,  addr_a2, addr_a2, 0);
      23          elseif cflag(now) = copy_test then
      24              call em2(q2_ccopy, addr_a2, addr_a2, 0);
      25          end if;
      26
      27      else
      28          opc = std_op(op);
      29      end if;
      30
      31      if can_assign(fm1, fm) then
      32          call em2(opc, addr_a1, addr_a2, 0);
      33
      34      else
      35          form(sym_t1_) = fm;
      36          call em2(opc, addr_t1, addr_a2, 0);
      37          call emconv(a1, sym_t1_, fm1, no);
      38          form(sym_t1_) = f_gen;
      39      end if;
      40
      41
      42      end subr emfrom;
       1 .=member emlessf
       2      subr emlessf;
       3
       4$ this routine emits code for 'lessf'. like 'with' and 'less'
       5$ either a1 = a2 or a1 is an internal variable with type general.
       6
       7
       8      size opc(ps);           $ q2 opcode
       9      size fm(ps);            $ dereferenced form of a2
      10
      11      access q1vars;          $ access global q1 variables.
      12      access nscod;           $ access variables global to cod.
      13
      14
      15      fm = deref_typ(fm2);
      16      if (is_fset(fm) & ^ is_fmap(fm)) fm = f_umap;
      17
      18      call set_a2(          fm, yes);
      19      call set_a3(dom_type(fm), no );
      20
      21      opc = spec_op(op, fm);
      22      if (opc = 0) opc = std_op(op);
      23$$--  disable for the sake of generated code
      24      if (is_fplex(fm)) opc = std_op(op);
      25$$--  end disabled section
      26
      27      if can_assign(fm1, fm) then
      28          call em2(opc, addr_a1, addr_a2, addr_a3);
      29
      30      else
      31          form(sym_t1_) = fm;
      32          call em2(opc, addr_t1, addr_a2, addr_a3);
      33          call emconv(a1, sym_t1_, fm1, no);
      34          form(sym_t1_) = f_gen;
      35      end if;
      36
      37
      38      end subr emlessf;
       1 .=member emnelt
       2      subr emnelt;
       3
       4$ this routine emits a1 := ? a2. we look for the special case where
       5$ the nelt of a set or tuple is being maintained.
       6
       7      size opc(ps);  $ q2 opcode
       8
       9      access q1vars;          $ access global q1 variables.
      10      access nscod;           $ access variables global to cod.
      11
      12
      13      opc = spec_op(q1_nelt, fm2);
      14
      15      if opc = 0 then  $ general case
      16          opc = q2_nelt;
      17
      18      elseif opc = q2_neltst then  $ set or tuple
      19          if (ft_neltok(fm2)) opc = q2_neltok;
      20      end if;
      21
      22      call em2(opc, addr_a1, addr_a2, 0);
      23
      24
      25      end subr emnelt;
       1 .=member emnewat
       2      subr emnewat;
       3
       4$ this routine processes 'a1 := newat;'. we catch the case where
       5$ a1 is an element of a plex base.
       6
       7      size bform(ps),  $ form of base
       8           baddr(ps);  $ address of base
       9
      10      access q1vars;          $ access global q1 variables.
      11      access nscod;           $ access variables global to cod.
      12
      13
      14      if ft_type(fm1) = f_elmt then
      15          bform = ft_base(fm1);
      16          baddr = ft_samp(bform);
      17
      18          if ft_type(bform) = f_pbase then
      19              call em2(q2_newat2, addr_a1, baddr, 0);
      20
      21          elseif ft_elmt(bform) = f_atom ! ft_elmt(bform) = f_gen then
      22              call em2(q2_newat1, addr_t1, 0, 0);
      23              call em2(q2_locate, addr_a1, addr_t1, baddr);
      24
      25          else    $ no other type is possible
      26              call ermsg(2, 0);
      27          end if;
      28
      29      elseif ft_type(fm1) = f_atom ! fm1 = f_gen then
      30          call em2(q2_newat1, addr_a1, 0, 0);
      31
      32      else  $ illegal type for a1
      33          call ermsg(2, 0);
      34      end if;
      35
      36
      37      end subr emnewat;
       1 .=member emof
       2      subr emof;
       3
       4$ this routine processes 'a1 := a2(a3)'.
       5
       6
       7      size opc(ps);           $ q2 opcode
       8      size opc1(ps);          $ q2 opcode
       9      size fm(ps);            $ dereferenced form of a2
smfb 184      size f3(ps);            $ dereferenced form of a3
      10
      11      size ok_conv(1);        $ checks for legal conversions
      12
      13      access q1vars;          $ access global q1 variables.
      14      access nscod;           $ access variables global to cod.
      15
      16
      17      fm = deref_typ(fm2);
      18      if (is_fset(fm) & ^ is_fmap(fm)) fm = f_umap;
      19
      20      if is_fmap(fm) then
      21          opc = of_op(q1_of, ft_type(fm), ft_mapc(fm));
      22      else
      23          opc = spec_op(q1_of, fm);
      24      end if;
      25
      26      if (opc = 0) opc = q2_of;
      27
      28      $ select special opcode to set share bit
      29      if sflag(now) & ^ is_fprim(compn_typ(fm, a3)) then
      30          opc1 = share_op(opc);
      31          if (opc1 ^= 0) opc = opc1;
      32      end if;
      33
      34      call set_a2(          fm, yes);
      35
      36      if ok_conv(dom_type(fm), fm3) then
smfb 185          if opc = q2_oft ! opc = q2_ofts then
smfb 186              f3 = ft_deref(fm3);
smfb 187              if ft_type(f3) = f_sint then
smfb 188                  if ft_lim(f3) ^= 0 & ft_lim(f3) <= ft_lim(fm) then
smfb 189                      if opc = q2_oft then
smfb 190                          opc = q2_oftok;
smfb 191                      else
smfb 192                          opc = q2_oftoks;
smfb 193                      end if;
smfb 194                  elseif is_const(a3) then
smfb 195                      if symval(a3) <= ft_lim(fm) then
smfb 196                          if opc = q2_oft then
smfb 197                              opc = q2_oftok;
smfb 198                          else
smfb 199                              opc = q2_oftoks;
smfb 200                          end if;
smfb 201                      end if;
smfb 202                  end if;
smfb 203              end if;
smfb 204              call set_a3(f_int, no);
smfb 205          else
smfb 206              call set_a3(dom_type(fm), no);
smfb 207          end if;
      38      else
      39          opc = q2_of;
      40      end if;
      41
      42      call em2(opc, addr_a1, addr_a2, addr_a3);
      43
      44
      45      end subr emof;
       1 .=member emofa
       2      subr emofa;
       3
       4$ this routine emits 'a1 := a2<>'.
       5
       6
       7      size opc(ps);           $ q2 opcode
       8      size opc1(ps);          $ q2 opcode
       9      size fm(ps);            $ dereferenced form of a2
      10
      11      size ok_conv(1);        $ checks for legal conversions
      12
      13      access q1vars;          $ access global q1 variables.
      14      access nscod;           $ access variables global to cod.
      15
      16
      17      fm = deref_typ(fm2);
      18      if (is_fset(fm) & ^ is_fmap(fm)) fm = f_umap;
      19
      20      if is_fmap(fm) then
      21          opc = of_op(q1_ofa, ft_type(fm), ft_mapc(fm));
      22      else
      23          opc = spec_op(q1_ofa, fm);
      24      end if;
      25
      26      if (opc = 0) opc = q2_ofa;
      27
      28      $ select special opcode to set share bit
      29      if sflag(now) then
      30          opc1 = share_op(opc);
      31          if (opc1 ^= 0) opc = opc1;
      32      end if;
      33
      34      call set_a2(          fm, yes);
      35
      36      if ok_conv(dom_type(fm), fm3) then
      37          call set_a3(dom_type(fm), no);
      38      else
      39          opc = q2_ofa;
      40      end if;
      41
      42      call em2(opc, addr_a1, addr_a2, addr_a3);
      43
      44
      45      end subr emofa;
       1 .=member emsof
       2      subr emsof;
       3
       4$ this routine emits a1(a2) := a3. we begin by converting a2 and a3
       5$ to the desired type, then select the proper opcode. if we are
       6$ are emitting in-line code then we must also emit an inline copy.
       7$ otherwise we allow the libraries 'sof' routine to perform the
       8$ copy.
       9
      10
      11      size opc(ps);           $ q2 opcode
      12      size fm(ps);            $ dereferenced form of a1
smfb 208      size f2(ps);            $ dereferenced form of a2
      13
      14      access q1vars;          $ access global q1 variables.
      15      access nscod;           $ access variables global to cod.
      16
      17
      18      fm = deref_typ(fm1);
      19      if (is_fset(fm) & ^ is_fmap(fm)) fm = f_umap;
      20
      21      if is_fmap(fm) then
      22          opc = of_op(q1_sof, ft_type(fm), ft_mapc(fm));
      23      else
      24          opc = spec_op(q1_sof, fm);
      25      end if;
      26
      29      if is_funt(compn_typ(fm, a2)) & ^ is_floc(fm) then
      30          $ until we fix this in the interpreter so that we can
      31          $ do it inline
      32          call typea3;   opc = q2_sof;
      33      else
      34          call set_a3(compn_typ(fm, a2), no);
      35      end if;
      36
      37      if opc = 0 then
      38          opc = q2_sof;
      39      elseif ft_type(fm) = f_mtuple then
smfb 209          if is_const(a2) & ft_type(ft_deref(fm2)) = f_sint then
      41              if (symval(a2) > ft_lim(fm)) call ermsg(21, a1);
      42          else
      43              opc = q2_sof;
      44          end if;
      45      end if;
smfb 210
smfb 211      if opc = q2_soft then
smfb 212$$-- must update nelt correctly - since this is not done at the moment
smfb 213$$-- we cannot emit the q2_softok.
smfb 214$$--          f2 = ft_deref(fm2);
smfb 215$$--          if ft_type(f2) = f_sint then
smfb 216$$--              if ft_lim(f2) ^= 0 & ft_lim(f2) <= ft_lim(fm) then
smfb 217$$--                  opc = q2_softok;
smfb 218$$--              elseif is_const(a2) then
smfb 219$$--                  if (symval(a2) <= ft_lim(fm)) opc = q2_softok;
smfb 220$$--              end if;
smfb 221$$--          end if;
smfb 222          call set_a2(f_int, no);
smfb 223      else
smfb 224          call set_a2(dom_type(fm), no);
smfb 225      end if;
      46
      47      if can_assign(fm1, fm) then
      48          call set_a1;
      49          call em2(opc, addr_a1, addr_a2, addr_a3);
      50
      51      else
      52          form(sym_t1_) = fm;
      53          call emconv(sym_t1_, a1, fm, cflag(now));
      54
      55          call em2(opc, addr_t1, addr_a2, addr_a3);
      56
      57          call emconv(a1, sym_t1_, fm1, no);
      58          form(sym_t1_) = f_gen;
      59      end if;
      60
      61
      62      end subr emsof;
       1 .=member emsofa
       2      subr emsofa;
       3
       4$ this routine emits 'a1<> := a3'.
       5
       6
       7      size opc(ps);           $ q2 opcode
       8      size fm(ps);            $ dereferenced form of a1
       9
      10      access q1vars;          $ access global q1 variables.
      11      access nscod;           $ access variables global to cod.
      12
      13
      14      fm = deref_typ(fm1);
      15      if (is_fset(fm) & ^ is_fmap(fm)) fm = f_umap;
      16
      17      if is_fmap(fm) then
      18          opc = of_op(q1_sofa, ft_type(fm), ft_mapc(fm));
      19      else
      20          opc = spec_op(q1_sofa, fm);
      21      end if;
      22
      23      if (opc = 0) opc = q2_sofa;
      24
      25      call set_a2( dom_type(fm), no);
      26      call set_a3(rset_type(fm), no);
      27
      28      if can_assign(fm1, fm) then
      29          call set_a1;
      30          call em2(opc, addr_a1, addr_a2, addr_a3);
      31
      32      else
      33          form(sym_t1_) = fm;
      34          call emconv(sym_t1_, a1, fm, cflag(now));
      35
      36          call em2(opc, addr_t1, addr_a2, addr_a3);
      37
      38          call emconv(a1, sym_t1_, fm1, no);
      39          form(sym_t1_) = f_gen;
      40      end if;
      41
      42
      43      end subr emsofa;
       1 .=member emst
       2      subr emst;
       3
       4$ this routine processes enumerative set and tuple formers.
       5$ there are two opcodes for sets and two for tuples
       6
       7$ q2_set1:   output is type general; decide at run time whether
       8$            to build set or map.
       9$ q2_set2:   all elements are proper type
      10
      11$ q2_tup1:   all elements are proper type
      12$ q2_tup2:   mixed tuple, elements require conversion
      13
      14$ note that q2_tup2 is only used for iterative tuple formers
      15$ where the result is a mixed tuple.
      16
      17$ these instructions all have:
      18
      19$ arg1:     pointer to result
      20$ arg2:     form of result
      21$ arg3:     pointer to short integer giving number of elements
      22
      23
      24      size j(ps),             $ loop index
      25           n(ps);             $ number of elements
      26
      27      size elmt(ps);          $ set/tuple element
      28
      29      size st_form(ps),       $ form of set/tuple
      30           elmt_form(ps);     $ form of set/tuple element
      31
      32      size opc(ps),           $ q2 opcode
      33           count_addr(ps);    $ address of counter
      34
      35      size genint(ps);        $ allocates integer
      36
      37      access q1vars;          $ access global q1 variables.
      38      access nscod;           $ access variables global to cod.
      39
      40
      41      $ get the form of the set/tuple
      42      st_form = deref_typ(fm1);
      43
      44      $ generate code to push the set/tuple components
      45      n = nargs(now);
      46      do j = 2 to n;
      47          elmt = argn(now, j);
      48
      49          if ft_type(st_form) = f_mtuple then
      50              elmt_form = mttab(ft_elmt(st_form)-1+j);
      51          else
      52              elmt_form = ft_elmt(st_form);
      53          end if;
      54
      55          call empush(elmt, elmt_form);
      56      end do;
      57
      58      $ allocate a constant for the number of elements
      59      count_addr = genint(n-1);
      60
      61      $ select proper opcode
      62      if op = q1_set then
      63          if st_form = f_gen then
      64              opc = q2_set1;   st_form = f_uset;
      65          else
      66              opc = q2_set2;
      67          end if;
      68
      69      else
      70          if (st_form = f_gen) st_form = f_tuple;
      71          opc = q2_tup1;
      72      end if;
      73
      74      $ see whether a conversion is necessary
      75      if can_assign(fm1, st_form) then
      76          call em2(       opc,  addr_a1,  st_form, count_addr);
      77      else
      78          call em2(       opc,  addr_t1,  st_form, count_addr);
      79
      80          form(sym_t1_) = st_form;
      81          call emconv(a1, sym_t1_, fm1, no);
      82          form(sym_t1_) = f_gen;
      83      end if;
      84
      85
      86      end subr emst;
       1 .=member emst1
       2      subr emst1;
       3
       4$ this routine processes iterative set and tuple formers.
       5$ it is similar to emst, above.
       6
       7      size fm(ps),  $ result type
       8           opc(ps);  $ q2 opcode
       9
      10      access q1vars;          $ access global q1 variables.
      11      access nscod;           $ access variables global to cod.
      12
      13
      14      fm = fm1;
      15
      16      if op = q1_set1 then
      17          if fm = f_gen then
      18              fm  = f_uset;
      19              opc = q2_set1;
      20          else
      21              opc = q2_set2;
      22          end if;
      23
      24      else
      25          if fm = f_gen then
      26              fm  = f_tuple;
      27              opc  = q2_tup1;
      28          elseif ft_type(fm) = f_mtuple then
      29              opc = q2_tup2;
      30          else
      31              opc = q2_tup1;
      32          end if;
      33      end if;
      34
      35      call em2(opc, addr_a1, fm, addr_a3);
      36
      37
      38      end subr emst1;
       1 .=member emst2
       2      subr emst2;
       3$
       4$ this routine processes the domain and range operations.
       5$ it is simillar to emst1, above.
       6$
       7      size fm(ps);            $ result set mode
       8
       9      access q1vars;          $ access global q1 variables.
      10      access nscod;           $ access variables global to cod.
      11
      12
      13      fm = fm1;
      14
smfb 226      if (fm = f_gen) fm = f_uset; if (^is_fset(fm)) call ermsg(22, a1);
      17
      18      call em2(std_op(op), addr_a1, addr_a2, fm);
      19
      20
      21      end subr emst2;
       1 .=member emargin
       2      subr emargin;
       3
       4$ this routine emits argin assignments. we convert the argument to
       5$ the proper type if necessary.
       6
       7$ we handle two special cases for build in procedures:
       8
       9$ 1. if the second argument of a string primitive is a constant
      10$    we build a pattern set and pass the set instead.
      11
      12$ 2. if the formal parameter type of a built in procedure is
      13$    type general and the argument type is anything other than
      14$    untyped integer or untyped real, we pass it without
      15$    conversion.
      16
      17
      18     size fm(ps),   $ desired type
      19          j(ps);    $ loop index
      20
      21     size mrouts(ps);   $ gives names of pattern matching routines
      22     dims mrouts(8);
      23
      24     data mrouts = sym_span, sym_break, sym_any, sym_notany,
      25                   sym_rspan, sym_rbreak, sym_rany, sym_rnotany;
      26
      27      size bldpset(ps);  $ builds a pattern set and returns its address
      28
      29      access q1vars;          $ access global q1 variables.
      30      access nscod;           $ access variables global to cod.
      31
      32
      33$ decide whether to build a pset
      34     if (^ is_const(a1)) go to not_pset;
      35     if (a3 ^= sym_two)  go to not_pset;
      36
      37     do j = 1 to 8;
      38         if (a2 = mrouts(j)) go to pset;
      39     end do;
      40
      41     go to not_pset;
      42
      43
      44 /pset/      $ push pset
      45
      46     call em2(q2_push1, bldpset(a1), 0, 0);
      47     return;
      48
      49
      50 /not_pset/  $ convert if necessary then push
      51
      52      fm = arg_type(a2, symval(a3));
      53
      54      if is_bip(a2) & fm = f_gen & ^ is_funt(fm1) then
      55          if (is_fplex(deref_typ(fm1))) call ermsg(11, a1);
      56          call em2(q2_push1, addr_a1, 0, 0);
      57
      58      else
      59          call empush(a1, fm);
      60      end if;
      61
      62      return;
      63
      64      end subr emargin;
       1 .=member emargout
       2      subr emargout;
       3
       4$ this routine emits argout assignments.
       5
       6      size fm(ps),    $ form of parameter
       7           back(1);   $ on if push must be backtracked
       8
       9      access q1vars;          $ access global q1 variables.
      10      access nscod;           $ access variables global to cod.
      11
      12
      13      fm = arg_type(a2, symval(a3));
      14
      15      back = (back_flag & ^ is_bip(a2));
      16
      17      call empop(a1, fm, back);
      18
      19
      20      end subr emargout;
       1 .=member empush
       2      subr empush(arg, fm);
       3
       4$ this routine emits code to convert 'arg' to type 'fm' and push
       5$ it on the stack.
       6
       7      size arg(ps),   $ item to be pushed
       8           fm(ps);    $ desired form
       9
      10      size xfm(ps),   $ original form
      11           addr(ps);  $ address
      12
      13      access q1vars;          $ access global q1 variables.
      14      access nscod;           $ access variables global to cod.
      15
      16
      17      xfm = form(arg);
      18      get_addr(addr, arg);
      19
      20      if can_assign(fm, xfm) then
      21          if is_funt(fm) then  $ untyped
      22              call em2(q2_push1u, addr, 0, 0);
      23          else
      24              call em2(q2_push1, addr, 0, 0);
      25          end if;
      26
      27      else  $ convert argument
      28          call emconv(sym_t1_, arg, fm, no);
      29
      30          if is_funt(fm) then  $ untyped
      31              call em2(q2_push1u, addr_t1, 0, 0);
      32          else
      33              call em2(q2_push1, addr_t1, 0, 0);
      34          end if;
      35      end if;
      36
      37
      38      end subr empush;
       1 .=member empop
       2      subr empop(arg, fm, back);
       3
       4$ this routine emits code to pop 'arg' from the stack. 'fm' is
       5$ the type of the stack entry.
       6
       7$ note that if the stack entry is an untyped integer or real we assumr
       8$ that it is preceeded by a skip word which must be popped first.
       9
      10      size arg(ps),   $ variable to be popped
      11           fm(ps),    $ form of stack entry
      12           back(1);   $ on if pop must be backtracked
      13
      14      size xfm(ps),   $ form of arg
      15           addr(ps);  $ address of arg
      16
      17      access q1vars;          $ access global q1 variables.
      18      access nscod;           $ access variables global to cod.
      19
      20
      21      xfm = form(arg);
      22      get_addr(addr, arg);
      23
      24      if can_assign(xfm, fm) then
      25          if back then
      26              if (is_funt(fm)) call em2(q2_bfree, address(sym_one),0,0);
      27              call em2(q2_bpop1, addr, 0, 0);
      28          else
      29              if (is_funt(fm)) call em2(q2_free, address(sym_one),0,0);
      30              call em2(q2_pop1, addr, 0, 0);
      31          end if;
      32
      33      else   $ pop value into t1_ then convert
      34
      35          if back then
      36              if (is_funt(fm)) call em2(q2_bfree, address(sym_one),0,0);
      37              call em2(q2_bpop1, addr_t1, 0, 0);
      38
      39          else
      40              if (is_funt(fm)) call em2(q2_free, address(sym_one),0,0);
      41              call em2(q2_pop1, addr_t1, 0, 0);
      42          end if;
      43
      44          form(sym_t1_) = fm;   $ pretend for now
      45
      46          call emconv(arg, sym_t1_, xfm, no);
      47
      48          form(sym_t1_) = f_gen;  $ reset
      49      end if;
      50
      51
      52      end subr empop;
       1 .=member emsubst
       2      subr emsubst;
       3
       4      access q1vars;          $ access global q1 variables.
       5      access nscod;           $ access variables global to cod.
       6
       7
       8      call typea2;
       9      call typea3;
      10
      11      if op = q1_end then
      12          call em2(q2_end, addr_a1, addr_a2, addr_a3);
      13
      14      else   $ q1_subst
      15          call em2(q2_subst, addr_a1, addr_a2, addr_a3);
      16
      17          a4 = arg4(now);
      18          get_addr(addr_a4, a4);
      19
      20          if (is_funt(form(a4))) call emconv(a4, a4, f_int, no);
      21
      22          call em2(q2_noop, addr_a4, 0, 0);
      23      end if;
      24
      25
      26      end subr emsubst;
       1 .=member emssubst
       2      subr emssubst;
       3
       4$ this routine emits 'a1(a2...a3) := a4' and 'a1(a2...) := a3'.
       5
       6
       7      size fm(ps);            $ dereferenced form of a1
       8      size need_conv(1);      $ conversion of result is needed
       9      size result(ps);        $ alias for a1
      10
      11      access q1vars;          $ access global q1 variables.
      12      access nscod;           $ access variables global to cod.
      13
      14
      15      fm = deref_typ(fm1);
      16      if (ft_type(fm) = f_mtuple) fm = f_tuple;
      17      need_conv = ^ can_assign(fm1, fm);
      18
      19      if need_conv then
      20          form(sym_t1_) = fm;   call emconv(sym_t1_, a1, fm, no);
      21
      22          result = addr_t1;
      23      else
      24          result = addr_a1;
      25      end if;
      26
      27
      28      call typea2;
      29
      30      if op = q1_send then
      31          call set_a3(fm, no);
      32          call em2(   q2_send,   result,  addr_a2,  addr_a3);
      33
      34      else   $ q1_ssubst
      35          call typea3;
      36
      37          a4 = arg4(now);
      38          get_addr(addr_a4, a4);
      39          call set_a4(fm, no);
      40
      41          call em2( q2_ssubst,   result,  addr_a2,  addr_a3);
      42          call em2(   q2_noop,  addr_a4,        0,        0);
      43      end if;
      44
      45      if need_conv then
      46          call emconv(a1, sym_t1_, fm1, no);   form(sym_t1_) = f_gen;
      47      end if;
      48
      49
      50      end subr emssubst;
       1 .=member emasn
       2      subr emasn;
       3
       4
       5$ this routine processes simple assignments. assignments fall
       6$ into three categories
       7
       8$ 1. a1 := om. there are two subcases:
       9
      10$     a. a1 is a local set or map. here we emit two instructions.
      11$        the first sets a1 to its sample value, and the second
      12$        nulls out the appropriate base fields.
      13
      14$    b. otherwise we simple set a1 to its sample value.
      15
      16$ 2. a1 = a2, where a1 and a2 have compatible types. here we
      17$    must check whether copying is necessary.
      18
      19$ 3. a1 = a2 where a1 and a2 have incompatible types. this case
      20$    is processed by emconv.
      21
      22
      23      size fm(ps),  $ form of null set or tuple
      24           opc(ps);  $ q2 opcode
      25
      26      access q1vars;          $ access global q1 variables.
      27      access nscod;           $ access variables global to cod.
      28
      29
      30      if a2 = sym_om then
      31          call em2(q2_asn, addr_a1, ft_samp(fm1), 0);
      32          if (is_floc(fm1)) call em2(q2_asnnl, addr_a1, fm1, 0);
      33
      34      elseif can_assign(fm1, fm2) then
      35
      36$ emit code based on copy flags
      37          go to case(cflag(now)) in copy_min to copy_max;
      38
      39          /case(copy_no)/
      40
      41              if sflag(now) then
      42                  opc = q2_asnsb;
      43              else
      44                  opc = q2_asn;
      45              end if;
      46
      47              go to esac;
      48
      49          /case(copy_yes)/
      50
      51              opc = q2_copy;
      52              go to esac;
      53
      54          /case(copy_test)/
      55
      56              opc = q2_ccopy;
      57              go to esac;
      58
      59
      60          /esac/
      61
      62              call em2(opc, addr_a1, addr_a2, 0);
      63
      64      else     $ conversion
smfb 227          call emconv(a1, a2, fm1, cflag(now));
      66      end if;
      67
      69
      70      end subr emasn;
       1 .=member emconv
       2      subr emconv(output, input, oform, copy);
       3
       4$ this routine emits all conversions. its arguments are
       5
       6$ output   symtab pointer to result of conversion
       7$ input    symtab pointer to input of conversion
       8$ oform    formtab pointer for result type
       9$ copy     copy option, see below.
      10
      11$ 'output' has type general or type ofrom.
      12
      13$ 'input' has type general or a type different from oform.
      14
      15$ if 'input' has type general then we will emit a test to see
      16$ whether a conversion is really necessary. if the conversion
      17$ proves unnecessary, we have two options:
      18
      19$ 1. set input's share bit and assign it to output.
      20
      21$ 2. copy input and assign the copy to output.
      22
      23$ the argument 'copy' is true if we desire option (2).
      24
      25
      26      size output(ps);        $ symtab pointer for output
      27      size input(ps);         $ symtab pointer for input
      28      size oform(ps);         $ desired mode for output
      29      size copy(2);           $ desired copy action
      30
      31      size iform(ps);         $ mode of input
      32      size otyp(ps);          $ ft_type of output
      33      size ityp(ps);          $ ft_type of input
      34      size oaddr(ps);         $ address of output
      35      size iaddr(ps);         $ address of input
      36
      37      size n(ps);             $ number of dereferences
      38      size f(ps);             $ dereferenced form
      39      size bform(ps);         $ form of base
      40      size baddr(ps);         $ address of base
      41      size opc(ps);           $ q2 opcode
      42      size min(ps);           $ lower bound of value
      43      size max(ps);           $ upper bound of value
      44      size laddr(ps);         $ address of label for skip instructions
smfb 228      size spec(hs);          $ specifier for form table repr string
smfb 229      size tstart(ps);        $ local copy of stack pointer
smfb 230      size hstart(ps);        $ local copy of heap pointer
      45
      46      size convcon(ps);       $ converts constant
smfd  34      size can_conv(1);       $ checks for legal conversions
      48      size genint(ps);        $ generates integer constant
smfb 231      size format_form(hs);   $ formats formtab entry into repr string
smfb 232
smfb 233      size retpt(ps);         $ return address for local subroutine
      49
      50      access q1vars;          $ access global q1 variables.
      51      access nscod;           $ access variables global to cod.
smfb 234
smfb 235 .=zzyorg a                   $ counter for return labels of local subr
      52
      53
      54$ we begin by getting information about the input and
      55$ the output.
      56      iform = form(input);
      57
      58      otyp = ft_type(oform);
      59      ityp = ft_type(iform);
      60
      61      get_addr(oaddr, output);
      62      get_addr(iaddr, input);
      63
      64$ if 'input' is a constant, we will usually build an extra copy of it
      65$ with type 'oform' rather than doing a run time conversion. note that
      66$ conversions to local set or map must be done at run time since they
      67$ involve changing output's base fields.
      68
      69$ if 'input' is the null set(tuple) we emit a special q2 instruction
      70$ which builds a null set(tuple) with type oform.
      71
      72      if input = sym_om then  $ assign proper omega
      73          call em2(q2_asn, oaddr, ft_samp(oform), 0);
      74          return;
      75
      76      elseif input = sym_nullset then $ generate proper << >>
      77
      78          if is_fset(oform) then
      79              call em2(q2_asnnl, oaddr, oform, 0);
      80              return;
      81
      82          elseif oform = f_gen then
      83              call em2(q2_asnnl, oaddr, f_uset, 0);
      84              return;
      85
      86          end if;
      87
      88      elseif input = sym_nulltup then $ generate proper (/ /)
      89
      90          if is_ftup(oform) then
      91              call em2(q2_asnnult, oaddr, oform, 0);
      92              return;
      93
      94          elseif oform = f_gen then
      95              call em2(q2_asnnult, oaddr, f_tuple, 0);
      96              return;
      97
      98          end if;
      99
     100      elseif is_const(input) & ^ is_floc(oform) then
     101          input = convcon(input, oform);
     102          get_addr(iaddr, input);
     103
     104          if copy ^= copy_no & ^ is_fprim(oform) then
     105              call em2(q2_copy, oaddr, iaddr, 0);
     106          else
     107              call em2(q2_asn, oaddr, iaddr, 0);
     108          end if;
     109
     110          return;
     111      end if;
     112
     113
     114$ see if we can dereference iform to get the type of oform.
     115
     116      n = 0;  $ no. of derefs
     117      f = iform;
     118
     119      while ft_type(f) = f_elmt & f ^= oform;
     120          if (ft_type(ft_base(f)) = f_pbase) quit while;
     121          f = ft_elmt(ft_base(f));
     122          n = n+1;
     123      end while;
     124
     125      if oform = f ! (otyp ^= f_elmt & n > 0) then
     126          $ emit proper dereference operation
     127          if n = 1 then opc = q2_deref1; else opc = q2_deref; end if;
     128
     129          call em2(opc, oaddr, iaddr, n);
     130
     131          if copy ^= copy_no then
     132              if copy = copy_yes then
     133                  opc = q2_copy;
     134              else
     135                  opc = q2_ccopy;
     136              end if;
     137
     138              call em2(opc, oaddr, oaddr, 0);
     139          end if;
     140
     141          if (oform = f) return;
     142
     143          iform = f;
     144          ityp  = ft_type(iform);
     145          iaddr = oaddr;
     146      end if;
     147
     148$ otherwise jump on otyp
     149
     150      go to case(otyp) in f_min to f_max;
     151
     152/case(f_gen)/    $ general
     153
     154$ most cases of 'general := declared' can be treated as simple
     155$ assignments. these trivial cases are always handled before calling
     156$ emconv.
     157
     158$ 'general := untyped int' is treated as 'int := untyped int'
     159      if (ityp = f_uint)  go to case(f_int);
     160
     161$ 'general := untyped real' is treated as 'real := untyped real'
     162      if (ityp = f_ureal) go to case(f_real);
     163
     164
     165$ suppose we have 'general := set(real)'. once the set of reals
     166$ has been assigned to an undeclared variable, we can perform any
     167$ set operation on it, for example 'general with 1'. therefore we
     168$ have no way of knowing whether it will remain a set of reals;
     169$ all we can say is that it remains a set.
     170
     171$ this means that we must treat 'general := set(mode)' as a
     172$ conversion to set(general). we must perform similar conversions
     173$ for maps and tuples.
     174
     175      if is_ftup(iform) then
     176          f = f_tuple;
     177
     178      elseif is_fmap(iform) then
     179          f = f_umap;
     180
     181      else
     182          f = f_uset;
     183      end if;
     184
     185      call em2(q2_convert, oaddr, iaddr, f);
     186
     187      return;
     188
     189/case(f_sint)/   $ integer
     190
     191$ there are four legal conversions here:
     192
     193$ 1. input is an untyped integer
     194$ 2. input is a 'long integer'. this really means union(long, short).
     195$ 3. input is type general
     196$ 4. input is a short integer with a different range.
     197
     198      if ityp = f_uint then
     199          call em2(q2_tint1, oaddr, iaddr, 0);
     200
smfb 236      elseif ityp = f_int then
smfb 237          min = ft_low(oform);
smfb 238          max = ft_lim(oform); if (max = 0) max = maxsi;
smfb 239          call em2(q2_asn,     oaddr, iaddr,       0          );
smfb 240          call em2(q2_checki1, oaddr, genint(min), genint(max));
smfb 241          return;
smfb 242
smfb 243      elseif ityp = f_gen then
     202          call em2(q2_checktp, oaddr, iaddr, oform);
     203
     204      elseif ityp = f_sint then
     205          call em2(q2_asn, oaddr, iaddr, 0);
     206          if ft_low(oform) <= ft_low(iform) then
     207              max = ft_lim(oform); if (max = 0) max = maxsi;
     208              if (max >= ft_lim(iform) & ft_lim(iform) > 0) return;
     209          end if;
     210
     211      else
     212          call ermsg(7, 0);
     213          return;
     214      end if;
     215
     216      if (can_assign(oform, iform)) return;
     217      min = ft_low(oform);
     218      max = ft_lim(oform); if (max = 0) max = maxsi;
     219      if (min = 0 & max = maxsi) return;
     220      call em2(q2_checki1, oaddr, genint(min), genint(max));
     221
     222      return;
     223
     224/case(f_sstring)/
     225
stra  67      $ need to insert code to handle f_sstring := f_string.
stra  68      $ currently handled by patch code in q2_checktp.
     226      if ityp = f_gen then
     227          call em2(q2_checktp, oaddr, iaddr, oform);
     228      else
     229          call ermsg(24, 0);
     230     end if;
     231
     232     return;
     233
     234
     235/case(f_atom)/
     236
     237      if ityp = f_elmt then
     238          call em2(q2_asn, oaddr, iaddr, 0);
     239      elseif ityp = f_gen then
     240          call em2(q2_chkatom, oaddr, iaddr, 0);
     241      else
     242          call ermsg(25, 0);
     243      end if;
     244
     245      return;
     246
     247
     248/case(f_latom)/  $ long atom
     249
     250      $ should never reach here - f_latom are elements of plex bases,
     251      $ but they will always end up in the f_elmt case, below.
     252      call abort('compiler error - f_latom in emconv');
     253
     254
     255/case(f_int)/    $ integer
     256
     257      if ityp = f_sint then
     258          call em2(q2_asn, oaddr, iaddr, 0);
     259
     260      elseif ityp = f_gen then
     261          call em2(q2_checki2, iaddr, 0, 0);
     262          call em2(q2_asn, oaddr, iaddr, 0);
     263
     264      elseif ityp = f_uint then
     265          call em2(q2_tint2, oaddr, iaddr, 0);
     266
     267      else
     268          call ermsg(7, 0);
     269      end if;
     270
     271      return;
     272
     273
     274/case(f_elmt)/    $ element
     275
     276$ see if 'input' is already the proper element type; if so
     277$ emit a locate.
     278
     279      bform = ft_base(oform);   $ get form and address of base
     280      baddr = ft_samp(bform);
     281
     282      if ft_type(bform) = f_pbase then
     283          if iform = f_gen ! ityp = f_atom then
     284              call em2(q2_eqform4, oaddr, iaddr, bform);
     285          else
     286              call ermsg(11, 0);
     287          end if;
     288          return;
     289      elseif ft_elmt(bform) = iform then
     290          call em2(q2_locate, oaddr, iaddr, baddr);
     291          return;
     292      end if;
     293
     294      go to full;
     295
     296
     297/case(f_uint)/
     298
     299$ there are three legal conversions:
     300
     301$ 1. input is a short int
     302$ 2. input is a long int
     303$ 3. input is general
     304      if ityp = f_sint then
     305          call em2(q2_uint1, oaddr, iaddr, 0);
     306
     307      elseif ityp = f_int .or. ityp = f_gen then
     308          call em2(q2_uint2, oaddr, iaddr, 0);
     309
     310      else
     311          call ermsg(7, 0);
     312      end if;
     313
     314      return;
     315
     316
     317/case(f_ureal)/
     318
     319$ there are two legal conversions:
     320
     321$ 1. input is real
     322$ 2. input is general
     323      if ityp = f_real then
     324          call em2(q2_ureal1, oaddr, iaddr, 0);
     325
     326      elseif ityp = f_gen then
     327          call em2(q2_ureal2, oaddr, iaddr, 0);
     328
     329      else
     330          call ermsg(8, 0);
     331      end if;
     332
     333      return;
     334
     335
     336/case(f_string)/
     337
stra  69      if ityp = f_sstring then
stra  70          call em2(q2_asn, oaddr, iaddr, 0);
stra  71
stra  72      elseif ityp = f_gen then
stra  73          $ need to introduce new opcode to check if a1 is string.
stra  74          $ currently handled by patch code in q2_checktp.
     339          call em2(q2_checktp, oaddr, iaddr, f_string);
     340      else
     341          call ermsg(1, 0);
     342      end if;
     343
     344      return;
     345
     346
     347/case(f_real)/    $ reals
     348
     349$ there are two legal conversions:
     350
     351$ 1. input is an untyped real
     352$ 2. input is general
     353
     354      if ityp = f_ureal then
     355          call em2(q2_treal, oaddr, iaddr, 0);
     356
     357      elseif ityp = f_gen then
     358          call em2(q2_checktp, oaddr, iaddr, f_real);
     359
     360      else
     361          call ermsg(8, 0);
     362      end if;
     363
     364      return;
     365
     366
     367/case(f_error)/     $ error
     368
     369$ the only valid conversion here is 'error := general', which is
     370$ merely a type check.
     371
     372      if ityp = f_gen then
     373          call em2(q2_checktp, oaddr, iaddr, f_error);
     374
     375      else
     376          call ermsg(8, 0);
     377      end if;
     378
     379      return;
     380
     381
     382/case(f_tuple)/   $ tuples
     383
     384/case(f_ptuple)/
     385
     386/case(f_ituple)/
     387
     388/case(f_rtuple)/
     389
     390/case(f_mtuple)/
     391
     392
     393/case(f_uset)/
     394
     395/case(f_umap)/
     396
     397/case(f_lset)/
     398
     399/case(f_rset)/
     400
     401/case(f_lmap)/
     402
     403/case(f_rmap)/
     404
     405/case(f_lpmap)/
     406
     407/case(f_limap)/
     408
     409/case(f_lrmap)/
     410
     411/case(f_rpmap)/
     412
     413/case(f_rimap)/
     414
     415/case(f_rrmap)/
     416
     417
     418      go to full;
     419
     420
     421/full/   $ full conversion
     422
     423$ check that conversion is legal.
smfd  35      if ^ can_conv(oform, iform) then
     425          call ermsg(3, 0);
     426
     427          if et_flag then  $ print trace information
     428              put, skip, 'forms are: ': oform, i, x(1): iform, i, skip;
     429              call sdump;
     430          end if;
     431
     432          return;
     433      end if;
     434
     435
     436      if ityp = f_gen then  $ emit test to see if conversion is necessar
     437
     438          if otyp = f_elmt then  $ test for elements on same base
     439              call em2(q2_eqform1, oaddr, iaddr, ft_base(oform));
     440
     441          elseif copy ^= copy_no then  $ test, copy if forms match
     442              call em2(q2_eqform2, oaddr, iaddr, oform);
     443
     444          else   $ test, set share bit
     445              call em2(q2_eqform3, oaddr, iaddr, oform);
     446          end if;
     447      end if;
     448
     449      call em2(q2_convert, oaddr, iaddr, oform);
     450
smfd  36      if asm_flag & (ityp = f_gen) then
smfd  37          $ generate a label for the skip instruction just generated
smfd  38          laddr = codep + inst_nw; call em2(q2_lab, laddr, 0, 0);
smfd  39      end if;
smfb 244
smfb 245      if rpr_flag > 1 then l_call(print_message); end if;
     455
     456      return;
     457
     458
     459/case(f_base)/
     460
     461/case(f_pbase)/
     462
     463      call abort('illegal attempt to convert base');
     464
     465
     466/case(f_proc)/  $ procedures, etc
     467
     468/case(f_memb)/
     469
     470/case(f_lab)/
     471
     472/case(f_uimap)/
     473
     474/case(f_urmap)/
     475
     476      call abort('attempt to convert to invalid type');
     477
     478/error/
     479
     480      call ermsg(9, 0);
     481      return;
smfb 246
smfb 247
smfb 248/print_message/               $ local subr to print conversion message
smfb 249
smfb 250      tstart = t; hstart = h;  $ save environment parameters
smfb 251      get_addr(s_rnames, sym_rnames);  $ set run-time names tuple
smfb 252      build_spec(spec, t_tuple, rnames); heap(s_rnames) = spec;
smfb 253
smfb 254      put ,skip;
smfb 255      if ^ is_internal(output) then
smfb 256          put ,'convert ' :symsds(output),a ,x;
smfb 257      elseif ^ is_internal(input) then
smfb 258          put ,'convert ' :symsds(input),a ,x;
smfb 259      else
smfb 260          put ,'insert conversion ';
smfb 261      end if;
smfb 262
smfb 263      spec = format_form(iform);
smfb 264      if filestat(out_file, column) + ss_len(value_ spec) > 75 then
smfb 265          put ,skip ,column(5);
smfb 266      end if;
smfb 267      put ,'from '; call print2(out_file, spec);
smfb 268
smfb 269      spec = format_form(oform);
smfb 270      if filestat(out_file, column) + ss_len(value_ spec) > 77 then
smfb 271          put ,skip ,column(5);
smfb 272      end if;
smfb 273      put ,'to '; call print2(out_file, spec);
smfb 274
smfb 275      put ,skip ,column(5);
smfb 276      put ,'at ' :symsds(curmemb),a ,'.' :symsds(currout),a
smfb 277          ,'.' :stmt_count,i ,'.' ,skip;
smfb 278
smfb 279      t = tstart; h = hstart;  $ restore run-time environment
smfb 280
smfb 281      go to rlab(retpt) in 1 to zzya;  $ return from local subroutine
     482
     483
     484      end subr emconv;
       1 .=member okconv
       2      fnct ok_conv(t1, t2);
       3
smfd  40$ this routine does a recursive test to see whether the conversion
smfd  41$ from t2 to t1 could cause a run-time error.
smfd  42
smfd  43      size t1(ps);            $ type of output
smfd  44      size t2(ps);            $ type of input
smfd  45
smfd  46      size ok_conv(1);        $ flag returned
smfd  47
smfd  48      size f1(ps), f2(ps);    $ copies of arguments
smfd  49      size n(ps);             $ length of mixed tuple
smfd  50      size j(ps);             $ loop index
smfd  51      size tstart(ps);        $ initial value of 't'
smfd  52
smfd  53      size cn_type(ps);       $ special version of 'compn_typ'
      19
      20      access q1vars;          $ access global q1 variables.
      21      access nscod;           $ access variables global to cod.
      22
      23$ push the original types onto the stack then use a work pile
      24$ technique.
      25
      26      tstart = t;
      27      push2(t1, t2);
      28
      29      while t ^= tstart;
      30          pop2(f2, f1);
      31
smfd  54          if (f1 = f2) cont;  $ no conversion necessary.
smfd  55
smfd  56          $ dereference element types.
smfd  57          if ft_type(f1) = f_elmt then
smfd  58              if (ft_lim(ft_base(f1)) ^= 0) go to error;  $ const base
smfd  59              f1 = deref_typ(f1);
smfd  60          end if;
smfd  61
      34          if (ft_type(f2) = f_elmt) f2 = deref_typ(f2);
      35
      36          if (f1 = f2) cont;  $ no conversion necessary.
      37
smfd  62          $ conversions between plex types are illegal.
      39          if (is_fplex(f1) ! is_fplex(f2)) go to error;
      40
smfd  63          if (f1 = f_gen)                  cont;
smfd  64
smfd  65          if ft_type(f1) = f_sint then
smfd  66              if ft_type(f2) = f_sint then
smfd  67                  if (ft_low(f1) > ft_low(f2)) go to error;
smfd  68                  if (ft_lim(f1) = 0)          cont;
smfd  69                  if (ft_lim(f2) = 0)          go to error;
smfd  70                  if (ft_lim(f1) < ft_lim(f2)) go to error;
smfd  71                  cont;
smfd  72              else
smfd  73                  go to error;
smfd  74              end if;
smfd  75          end if;
      42
      43          if (is_fint(f1)  & is_fint(f2))  cont;
      44          if (is_freal(f1) & is_freal(f2)) cont;
      45          if (is_fstr(f1)  & is_fstr(f2))  cont;
      46
smfd  76          $ any remaining primitive types are incompatible.
      48          if (is_fprim(f1) ! is_fprim(f2)) go to error;
      49
      50
      51          if is_fset(f1) & is_fset(f2) then  $ two sets
      52              push2(ft_elmt(f1), ft_elmt(f2));
      53              cont;
      54
      55          elseif ft_type(f1) = f_mtuple ! ft_type(f2) = f_mtuple then
smfd  77
smfd  78              if ft_type(f1) = f_mtuple then
smfd  79                  if ft_type(f2) = f_mtuple then
smfd  80                      if (ft_lim(f1) < ft_lim(f2)) go to error;
smfd  81                  else
smfd  82                      go to error;
smfd  83                  end if;
smfd  84              end if;
      56              n = ft_lim(f1);
      57              if (n < ft_lim(f2)) n = ft_lim(f2);
      58
      59              do j = 1 to n;
      60                  push2(cn_type(f1, j), cn_type(f2, j));
      61              end do;
      62
      63              cont;
      64
      65          elseif is_ftup(f1) & is_ftup(f2) then $ two homogeneous tuple
      66              push2(ft_elmt(f1), ft_elmt(f2));
      67              cont;
      68
      69          else   $ set and tuple
      70              go to error;
      71          end if;
      72
      73      end while;
      74
      75      ok_conv = yes;
      76
      77      return;    $ valid conversion
      78
      79/error/
      80
      81      t = tstart;  $ restore;
      82
      83      ok_conv = no;
      84
      85      return;
      86
      87      end fnct ok_conv;
smfd  85      fnct can_conv(t1, t2);
smfd  86
smfd  87$ this routine does a recursive test to see whether the conversion from
smfd  88$ t2 to t1 is legal, i.e. whether a run-time conversion can succeed.
smfd  89
smfd  90      size t1(ps);            $ type of output
smfd  91      size t2(ps);            $ type of input
smfd  92
smfd  93      size can_conv(1);       $ flag returned
smfd  94
smfd  95      size f1(ps), f2(ps);    $ copies of arguments
smfd  96      size n(ps);             $ length of mixed tuple
smfd  97      size j(ps);             $ loop index
smfd  98      size tstart(ps);        $ initial value of 't'
smfd  99
smfd 100      size cn_type(ps);       $ special version of 'compn_typ'
smfd 101
smfd 102      access q1vars;          $ access global q1 variables.
smfd 103      access nscod;           $ access variables global to cod.
smfd 104
smfd 105$ push the original types onto the stack then use a work pile
smfd 106$ technique.
smfd 107
smfd 108      tstart = t;
smfd 109      push2(t1, t2);
smfd 110
smfd 111      while t ^= tstart;
smfd 112          pop2(f2, f1);
smfd 113
smfd 114          $ dereference element types.
smfd 115          if (ft_type(f1) = f_elmt) f1 = deref_typ(f1);
smfd 116          if (ft_type(f2) = f_elmt) f2 = deref_typ(f2);
smfd 117
smfd 118          if (f1 = f2) cont;  $ no conversion necessary.
smfd 119
smfd 120          $ conversions to or from plex types are illegal.
smfd 121          if (is_fplex(f1) ! is_fplex(f2)) go to error;
smfd 122
smfd 123          if (f1 = f_gen ! f2 = f_gen)     cont;
smfd 124
smfd 125          if (is_fint(f1)  & is_fint(f2))  cont;
smfd 126          if (is_freal(f1) & is_freal(f2)) cont;
smfd 127          if (is_fstr(f1)  & is_fstr(f2))  cont;
smfd 128
smfd 129          $ any remaining primitive types are incompatible
smfd 130          if (is_fprim(f1) ! is_fprim(f2)) go to error;
smfd 131
smfd 132
smfd 133          if is_fset(f1) & is_fset(f2) then  $ two sets
smfd 134              push2(ft_elmt(f1), ft_elmt(f2));
smfd 135              cont;
smfd 136
smfd 137          elseif ft_type(f1) = f_mtuple ! ft_type(f2) = f_mtuple then
smfd 138              n = ft_lim(f1);
smfd 139              if (n < ft_lim(f2)) n = ft_lim(f2);
smfd 140
smfd 141              do j = 1 to n;
smfd 142                  push2(cn_type(f1, j), cn_type(f2, j));
smfd 143              end do;
smfd 144
smfd 145              cont;
smfd 146
smfd 147          elseif is_ftup(f1) & is_ftup(f2) then  $ two homogeneous tuple
smfd 148              push2(ft_elmt(f1), ft_elmt(f2));
smfd 149              cont;
smfd 150
smfd 151          else   $ set and tuple
smfd 152              go to error;
smfd 153          end if;
smfd 154
smfd 155      end while;
smfd 156
smfd 157      can_conv = yes;
smfd 158
smfd 159      return;  $ valid conversion
smfd 160
smfd 161
smfd 162/error/
smfd 163
smfd 164      t = tstart;  $ restore;
smfd 165
smfd 166      can_conv = no;
smfd 167
smfd 168      return;
smfd 169
smfd 170      end fnct can_conv;
       1 .=member convcon
       2      fnct convcon(nam, fm);
       3
       4$ this is the top level routine for converting constants. we
       5$ check whether 'nam' can be given a type 'fm' then call cnvcon
       6$ to do further processing. there are five possibilities:
       7
       8$ 1. nam already has a representation as fm, so we return it.
       9
      10$ 2. fm and nam seem compatible. that is they are both
      11$    sets, both tuples, etc. in this case we accept the repr, and
      12$    defer further checking until later.
      13
      14$ 3. fm is general. there are two possibilities here:
      15
      16$    a. nam is a primitve type or a standard type such as 'set(*)'.
      17$       in this case we simply return.
      18
      19$    b. nam has a more specific set or tuple type. this will
      20$       arise in 'a := [1, 2]' where a is undeclared and the
      21$       tuple former is typed tuple(int) by the compiler.
      22
      23$       in this case we must reset nam's form to a more general
      24$       type, i.e. tuple(*). this is necessary so that a later
      25$       assignment 'a(1) := 1.0' can be done without resetting
      26$       a's type.
      27
      28$ 4. fm is type element.
      29
      30$ 5. otherwise we issue an error message.
      31
      32$ note that convcon will never be called to convert 'nam' to a local
      33$ set or map. these conversions must be done at run time since they
      34$ involve resetting the fields of the variable to which the constant
      35$ is being assigned.
      36
      37      size nam(ps),  $ name of symbolic constant
      38           fm(ps);  $ desired type
      39      size convcon(ps);  $ new symtab pointer
      40
      41      size ifm(ps),  $ form of input
      42           ofm(ps),  $ form of output
      43           elmt(ps);  $ new entry of type element
smfb 282      size v(ws);             $ value of integer constant
      44
      45      size cnvcon(ps),  $ lower level conversion function
      46           genelmt(ps);  $ generates constant of type element
      47
      48      access q1vars;          $ access global q1 variables.
      49      access nscod;           $ access variables global to cod.
      50
      51$ find the input and output types. note that if 'fm' is general
      52$ we will determine the output type from the input type.
      53      ifm = form(nam);
      54      ofm = fm;
      55
      56      if ofm = f_gen then
      57          if is_ftup(ifm) then
      58              ofm = f_tuple;
      59          elseif is_fmap(ifm) then
      60              ofm = f_umap;
      61          elseif is_fset(ifm) then
      62              ofm = f_uset;
      63          else
      64              ofm = ifm;
      65          end if;
      66      end if;
      67
      68$ see if nam already has a representation 'ofm'.
      69
      70      convcon = nam;
      71
      72      while convcon ^= 0;
      73          if (form(convcon) = ofm) return;
      74
      75          convcon = altrep(convcon);
      76      end while;
      77
      78$ otherwise see if ofm and ifm are compatible
      79
smfb 283      if ft_type(ofm) = f_sint & is_fint(ifm) then
smfb 284          v = symval(nam);
smfb 285          if ft_low(ofm) <= v &  $ range check needed
smfb 286                  (v <= ft_lim(ofm) ! ft_lim(ofm) = 0 & v <= maxsi) then
smfb 287              convcon = cnvcon(nam, ofm);
smfb 288          else
smfb 289              call ermsg(07, 0);
smfb 290          end if;
smfb 291
smfb 292      elseif ofm = f_int & ft_type(ifm) = f_sint then
smfb 293          convcon = nam;
smfb 294
smfb 295      elseif (is_fint(ofm)  & is_fint(ifm))  !     $ two integers
      81             (is_freal(ofm) & is_freal(ifm)) !     $ two reals
      82             (is_ftup(ofm)  & is_ftup(ifm))  !     $ two tuples
      83             (is_fset(ofm)  & is_fset(ifm)) then   $ two sets (maps)
      84
      85          convcon = cnvcon(nam, ofm);
      86
      87      elseif ft_type(ofm) = f_elmt then
      88          convcon = genelmt(nam, ofm);
      89
      90      else
      91          call ermsg(10, nam);
      92      end if;
      93
      94
      95      end fnct convcon;
       1 .=member cnvcon
       2      fnct cnvcon(nam, fm);
       3
       4$ this is the lower level function for converting constants.
       5$ at this point we know that 'nam' can be given a type of
       6$ 'fm'. there are two possibilities:
bnda  12$
       8$ 1. nam is an internally generated constant. this means
       9$    that it is only used by one instruction. we merely
      10$    reset its form field so that it is built with type fm.
bnda  13$
      12$ 2. nam appears in the source program. this means that it
      13$    can be used more than once and may have several reprs.
      14$    we generate a new symtab entry for this repr and assign
      15$    it storage then proceed as in (1).
      16
bnda  14      size nam(ps);           $ symtab index of constant
bnda  15      size fm(ps);            $ formtab index of constant
      19
bnda  16      size cnvcon(ps);        $ new symtab index returned
      21
      22      access q1vars;          $ access global q1 variables.
      23      access nscod;           $ access variables global to cod.
      24
      25
bnda  17      if is_internal(nam) & is_seen(nam) = no then
bnda  18          is_seen(nam) = yes;
      27          cnvcon = nam;
      28
      29      else
      30          countup(symtabp, symtab_lim, 'symtab');
      31          cnvcon = symtabp;
      32
      33          symtab(cnvcon)   = symtab(nam);
      34          name(cnvcon)     = 0;
smfb 296
smfb 297          if ft_type(form(nam)) = f_sint & ft_type(fm) = f_sint then
smfb 298              $ no new run-time symbol table entry is needed
smfb 299              alias(cnvcon) = nam; is_store(cnvcon) = no;
smfb 300              if (alias(nam) ^= 0) alias(cnvcon) = alias(nam);
smfb 301
smfb 302          else
smfb 303              $ create a new run-time symbol table entry
smfb 304              alias(cnvcon) = 0; is_store(cnvcon) = yes;
smfb 305
smfb 306              get_symtab(1); address(cnvcon) = sym_lim;
smfb 307              call iname('', 0, sym_lim);
smfb 308
smfb 309              if is_funt(fm) then  $ allocate skip word
smfb 310                  get_symtab(1); build_spec(heap(sym_lim), t_skip, 2);
smfb 311                  call iname('', 0, sym_lim);
smfb 312              end if;
smfb 313          end if;
smfb 314
smfb 315          $ link new entry into alternate representation chain
smfb 316          altrep(cnvcon) = altrep(nam); altrep(nam) = cnvcon;
      47      end if;
      48
      49      form(cnvcon) = fm;
      50
      51
      52      end fnct cnvcon;
       1 .=member genelmt
       2      fnct genelmt(nam, fm);
       3
       4$ this routine generates a constant of type element. v is the
       5$ constants value and fm is its form.
       6
       7
       8      size nam(ps),  $ original constant
       9           fm(ps);  $ type of element
      10
      11      size genelmt(ps);  $ pointer returned
      12
      13      size nam1(ps);          $ local copy of original constant
      14
      15      access q1vars;          $ access global q1 variables.
      16      access nscod;           $ access variables global to cod.
      17
      18
      19      nam1 = alias(nam);   if (nam1 = 0) nam1 = nam;
      20
      21      countup(symtabp, symtab_lim, 'symtab');
      22      genelmt = symtabp;
      23
      24      symtab(genelmt)   = 0;
      25
      26      is_repr(genelmt)  = yes;
      27      is_read(genelmt)  = yes;
      28      is_store(genelmt) = yes;
      29
      30      form(genelmt)     = fm;
      31
      32      altrep(genelmt)   = altrep(nam);  $ link into chain
      33      altrep(nam)       = genelmt;
      34
      35      get_symtab(1);   address(genelmt) = sym_lim;
smfa 169      call iname('', 0, sym_lim);
      37
      38      countup(valp, val_lim, 'val');
      39      val(valp) = nam1;
      40
      41      vptr(genelmt) = valp;
      42      vlen(genelmt) = 1;
      43
      44
      45      end fnct genelmt;
       1 .=member bldpset
       2      fnct bldpset(nam);
       3
       4$ this routine builds a set whose elements are the characters
       5$ contained in a given string. these sets are called psets and
       6$ are represented as 'packed tuple(1...1)' whose i-th component is
       7$ 1 if the character with code 'i' is in the set and 0 otherwise.
       8$ (note that 0 is the packed representation of omega.)
       9
      10$ psets are built on the fly during code generation. this means that
      11$ the run time value of 'nam' has not yet been built.
      12
      13      size nam(ps);  $ symtab pointer for string
      14
      15      size bldpset(ps);  $ run time symbol table address
      16
      17      size tup(ps),  $ specifier for tuple
      18           p(ps),    $ pointer to tuple
      19           j(ps),    $ loop index
      20           str(sds_sz),   $ nam as sds, including surrounding quotes
      21           c(cs);    $ character
      22      size old(ps);           $ pointer to sample value
      23      size len(ps);           $ total allocation
      24      size spec(hs);          $ specifier for pattern set
      25
      26      access q1vars;          $ access global q1 variables.
      27      access nscod;           $ access variables global to cod.
      28
      29
      30$ get run time symbol table entry
      31      get_symtab(1);   bldpset = sym_lim;
smfa 170      call iname('', 0, bldpset);
      32
      33$ get null tuple then set its value
      34
      35$ if we generate code in the dynamic part of the heap, we must allocate
      36$ this tuple in the constant area.  we can do this since psets are live
      37$ for the duration of execution, and their components are primitive.
      38
      39      old = value(ft_samp(f_pset));
      40      len = palloc(old, cs_sz-1);
      41
      42      if asm_flag then get_const(len, p); else get_heap(len, p); end if;
      43
      44      do j = 0 to hl_ptuple-1;   heap(p+j) = heap(old+j); end do;
      45      do j = hl_ptuple to len-1; heap(p+j) = 0;           end do;
      46
      47      maxindx(p) = cs_sz-1;
      48      nelt(p)    = cs_sz-1;
      49
      50      build_spec(spec, t_stuple, p);   heap(bldpset) = spec;
      51
      52
      53$ get the value of the string as an sds
      54
      55      str = 0;
      56
      57      do j = 0 to vlen(nam) - 1;
      58          .f. 1 + j*ws, ws, str = val(vptr(nam) + j);
      59      end do;
asca  18 .+ascebc if (ascebc_flag) call ascsds(str);  $ convert to ascii
      60
      61$ set the bit corresponding to each character in the string
      62
      63      do j = 1 to .len. str;
      64          c = .ch. j, str;
      65          psetcomp(p, c) = 1;
      66      end do;
      72
      73
      74      end fnct bldpset;
       1 .=member canasn
       2      fnct can_assign(f1, f2);
       3
       4$ this function returns true if an object of type f2 can be assigned
       5$ to a variable of type f1, i.e. if the assignment 'f1 := f2' can
       6$ be done without a conversion.
       7
       8      size f1(ps),  $ target type
       9           f2(ps);  $ input type
      10
      11      size can_assign(1);
      12
      13      access q1vars;          $ access global q1 variables.
      14      access nscod;           $ access variables global to cod.
      15
      16
      17      if (f1 = f2) go to pass;   $ types match
      18
      19      if (ft_type(f1) = f_int & ft_type(f2) = f_sint) go to pass;
      20
      21      if ft_type(f1) = f_sint & ft_type(f2) = f_sint then
      22          if (ft_low(f1) > ft_low(f2)) go to fail;
      23          if (ft_lim(f1) = 0)          go to pass;
      24          if (ft_lim(f2) = 0)          go to fail;
      25          if (ft_lim(f1) < ft_lim(f2)) go to fail;
      26          go to pass;
      27      end if;
      28
      29      if (ft_type(f1) = f_string & ft_type(f2) = f_sstring) go to pass;
      30
      31      if (f1 ^= f_gen) go to fail;  $ target not general
      32
      33      go to case(ft_type(f2)) in f_min to f_max;
      34
      35/case(f_gen)/    $ general
      36
      37/case(f_sint)/        $ short int
      38
      39/case(f_sstring)/      $ short string
      40
      41/case(f_atom)/       $ short atom
      42
      43/case(f_latom)/      $ 'long' atom
      44
      45/case(f_elmt)/       $ element
      46
      47/case(f_error)/
      48
      49      go to pass;
      50
      51/case(f_uint)/  $ untyped int
      52
      53/case(f_ureal)/  $ untyped real
      54
      55      go to fail;
      56
      57/case(f_int)/       $ long or short integer
      58
      59/case(f_string)/     $ long or short chars
      60
      61/case(f_real)/       $ real
      62
      63      go to pass;
      64
      65/case(f_ituple)/     $ integer tuple
      66
      67/case(f_rtuple)/     $ real tuple
      68
      69/case(f_ptuple)/  $ packed tuple
      70
      71      go to fail;
      72
      73/case(f_tuple)/ $ std. tuple
      74
      75      if (ft_elmt(f2) = f_gen) go to pass;
      76      go to fail;
      77
      78/case(f_mtuple)/     $ mixed tuple
      79
      80      go to fail;
      81
      82/case(f_uset)/       $ standard set
      83
      84      if (ft_elmt(f2) = f_gen) go to pass;
      85      go to fail;
      86
      87/case(f_lset)/       $ local subset
      88
      89      go to fail;
      90
      91/case(f_rset)/       $ remote subset
      92
      93      if (ft_elmt(ft_base(f2)) = f_gen) go to pass;
      94      go to fail;
      95
      96/case(f_umap)/       $ standard map
      97
      98      if (ft_elmt(f2) = f_gen) go to pass;
      99      go to fail;
     100
     101/case(f_lmap)/       $ local map
     102
     103      go to fail;
     104
     105/case(f_rmap)/       $ remote map
     106
     107/case(f_lpmap)/      $ local packed map
     108
     109/case(f_limap)/      $ local integer map
     110
     111/case(f_lrmap)/      $ local real map
     112
     113/case(f_rpmap)/      $ remote packed map
     114
     115/case(f_rimap)/      $ remote integer map
     116
     117/case(f_rrmap)/      $ remote real map
     118
     119/case(f_base)/       $ base
     120
     121/case(f_pbase)/   $ plex  base
     122
     123/case(f_uimap)/
     124
     125/case(f_urmap)/
     126
     127/case(f_proc)/   $ procedure or operator
     128
     129/case(f_memb)/  $ member
     130
     131/case(f_lab)/  $ label
     132
     133      go to fail;
     134
     135/pass/   $ return true
     136
     137      can_assign = yes;
     138      return;
     139
     140/fail/    $ return false
     141
     142      can_assign = no;
     143      return;
     144
     145      end fnct can_assign;
       1 .=member matchr
       2      subr match_repr(addr, arg, fm);
       3
       4$ this routine tries to find an alternate representation of
       5$ 'arg' with type 'fm'.
       6
       7$ on input we have:
       8
       9$ arg:      symtab pointer to a variable or constant
      10$ addr:     its address
      11$ fm:       desired type
      12
      13$ if arg is a constant and it has an alternate repr of type fm
      14$ we reset arg and addr to point to the alternate repr.
      15
      16      size addr(ps),    $ address
      17           arg(ps),     $ symtab pointer
      18           fm(ps);      $ form
      19
smfb 317      size p(ps);             $ pointer through alternate repr chain
smfb 318      size v(ws);             $ value of integer constant
smfb 319
smfb 320      size convcon(ps);       $ converts constant
      21
      22      access q1vars;          $ access global q1 variables.
      23      access nscod;           $ access variables global to cod.
      24
      25
      26      if (^ is_const(arg)) return;
      27
      28      if (fm = f_gen ! fm = form(arg)) return;
      29
      30      p = altrep(arg);
      31
      32      while p ^= 0;
      33          if form(p) = fm then
      34              arg = p;
      35              get_addr(addr, arg);
      36              return;
      37          end if;
      38
      39          p = altrep(p);
      40      end while;
      41
smfb 321      if ft_type(fm) = f_sint & is_fint(form(arg)) then
smfb 322          v = symval(arg);
smfb 323          if ft_low(fm) <= v &  $ range check needed
smfb 324                  (v <= ft_lim(fm) ! ft_lim(fm) = 0 & v <= maxsi) then
smfb 325              arg = convcon(arg, fm); get_addr(addr, arg);
smfb 326          end if;
smfb 327      elseif is_fint(fm)  & is_fint(form(arg))   !
smfb 328             is_freal(fm) & is_freal(form(arg)) then
smfb 329          arg = convcon(arg, fm); get_addr(addr, arg);
smfb 330      end if;
smfb 331
      43
      44      end subr match_repr;
       1 .=member seta1
       2      subr set_a1;
       3
       4$ this routine is called before using a1 as an input, for example
       5$ in 'a1(a2) := a3' . we emit any necessary copy.
       6$ if addr_a1 = addr_a3 then we are doing 'f(x) := f'. before we
       7$ can emit a copy, we must emit 't3_ := a3' and set
       8$ addr_a3 = addr_t3.
       9
      10      access q1vars;          $ access global q1 variables.
      11      access nscod;           $ access variables global to cod.
      12
      13      if addr_a1 = addr_a3 & cflag(now)     ^= copy_no then
      14          call em2(q2_asnsb, addr_t3, addr_a3, 0);
      15          addr_a3 = addr_t3;
      16      end if;
      17
      18
      19      go to case(cflag(now)) in copy_no to copy_test;
      20
      21/case(copy_no)/     $ no copy
      22
      23      return;
      24
      25/case(copy_yes)/   $ unconditional copy
      26
      27      call em2(q2_copy, addr_a1, addr_a1, 0);
      28      return;
      29
      30/case(copy_test)/  $ conditional copy
      31
      32      if (fm1 = f_string) go to case(copy_yes);  $ always copy
      33
      34      if (is_floc(fm1)) return;  $ never shared
      35
      36      call em2(q2_ccopy, addr_a1, addr_a1, 0);
      37      return;
      38
      39      end subr set_a1;
       1 .=member seta2
       2      subr set_a2(fm, exact);
       3
       4$ this routine is called before using a2 as an input, for example
       5$ in 'a1 := a2 + a3'. its arguments are:
       6
       7$ fm:       the desired form for a2
       8
       9$ exact:    1 if we require a2 to have exactly this type
      10$           0 if we allow a2 to have a more specific type
      11
      12$ we perform any necessary copying and conversion.
      13
      14      size fm(ps),    $ desired form
      15           exact(1);  $ indicates form must be exactly 'fm'.
      16
      17      size opc(ps);  $ q2 opcode
      18
      19      access q1vars;          $ access global q1 variables.
      20      access nscod;           $ access variables global to cod.
      21
      22
      23      if a2 = sym_om then  $ use desired omega
      24          addr_a2 = ft_samp(fm);
      25          if (is_floc(fm)) call em2(q2_asnnl, addr_a2, fm, 0);
      26          return;
      27      end if;
      28
      29$ see if conversion is required
      30
      31      if exact then
      32          if (same_repr(fm, fm2)) go to copy;
      33      else
      34          if (can_assign(fm, fm2)) go to copy;
      35      end if;
      36
      37/conv/      $ conversion necessary
      38
smfd 171      if op = q1_sof ! op = q1_sofa ! op = q1_ssubst ! op = q1_send then
smfd 172          $ cflag refers to a1.
smfd 173          call emconv(sym_t2_, a2, fm, copy_no);
smfd 174      else
smfd 175          call emconv(sym_t2_, a2, fm, cflag(now));
smfd 176      end if;
      40      addr_a2 = addr_t2;
      41
      42      return;
      43
      44/copy/      $ copy if necessary
      45
      46$ if the current opcode is q1_sof, etc. then the copy flag refers
      47$ to a1, and we can make a direct return.
      48
      49      if (op = q1_sof ! op = q1_sofa) return;
      50      if (op = q1_ssubst ! op = q1_send) return;
      51
      52$ otherwise copy a2 if it is long and used destructively
      53      if (is_fnum(fm2)) return;
      54
      55      go to case(cflag(now)) in copy_no to copy_test;
      56
      57/case(copy_no)/
      58
      59      return;
      60
      61/case(copy_yes)/
      62
      63      opc = q2_copy;
      64      go to esac;
      65
      66/case(copy_test)/
      67
      68      if (fm2 = f_string) go to case(copy_yes);  $ always copy
      69
      70      if (is_floc(fm2)) return;  $ never shared
      71
      72      opc = q2_ccopy;
      73
      74/esac/
      75
      76      call em2(opc, addr_t2, addr_a2, 0);
      77      addr_a2 = addr_t2;
      78
      79      return;
      80
      81      end subr set_a2;
       1 .=member seta3
       2      subr set_a3(fm, exact);
       3
       4$ this routine is called before using a3 as an input, for example
       5$ in 'a1 := a2 + a3'. its arguments are:
       6
       7$ fm:       the desired form for a3
       8
       9$ exact:    1 if we require a3 to have exactly this type
      10$           0 if we allow a3 to have a more specific type
      11
      12$ we perform any necessary share bit setting and conversion.
      13
      14      size fm(ps),    $ desired form
      15           exact(1);  $ indicates form must be exactly 'fm'.
      16
      17      access q1vars;          $ access global q1 variables.
      18      access nscod;           $ access variables global to cod.
      19
      20
      21      if a3 = sym_om then  $ use desired omega
      22          addr_a3 = ft_samp(fm);
      23          return;
      24      end if;
      25
      26$ see if conversion is required
      27
      28      if exact then
      29          if (same_repr(fm, fm3)) go to set;
      30      else
      31          if (can_assign(fm, fm3)) go to set;
      32      end if;
      33
      34/conv/      $ conversion necessary
      35
      36      call emconv(sym_t3_, a3, fm, no);
      37      addr_a3 = addr_t3;
      38
      39      return;
      40
      41/set/  $ set share bit if necessary
      42
      43      if (is_const(a3)) return;
      44      if (is_fprim(fm3)) return;
      45      if (is_floc(fm3))  return;
      46      if (op = q1_of)    return;
      47      if (op = q1_ofa)   return;
      48
      49      if (sflag(now) = no) return;
      50
      51      call em2(q2_share, addr_a3, 0, 0);
      52      return;
      53
      54      end subr set_a3;
       1 .=member seta4
       2      subr set_a4(fm, exact);
       3
       4$ this routine is called before using a4 as an input, for example
       5$ in 'a1(a2 ... a3) := a4'. its arguments are:
       6
       7$ fm:       the desired form for a4
       8
       9$ exact:    1 if we require a4 to have exactly this type
      10$           0 if we allow a4 to have a more specific type
      11
      12$ we perform any necessary conversion.
      13
      14      size fm(ps),    $ desired form
      15           exact(1);  $ indicates form must be exactly 'fm'.
      16
      17      access q1vars;          $ access global q1 variables.
      18      access nscod;           $ access variables global to cod.
      19
      20
      21      if a4 = sym_om then     $ use desired omega
      22          addr_a4 = ft_samp(fm);
      23          return;
      24      end if;
      25
      26$ see if conversion is required
      27
      28      if exact then
      29          if (same_repr(fm, fm4)) return;
      30      else
      31          if (can_assign(fm, fm4)) return;
      32      end if;
      33
      34      call emconv(sym_t4_, a4, fm, no);
      35      addr_a4 = addr_t4;
      36
      37
      38      end subr set_a4;
       1 .=member typea1
       2      subr typea1;
       3
       4$ this routine is called before emitting a q2 instruction which
       5$ might pass a1 to the run time library. it checks that a1 is
       6$ a typed quantity; if not it makes the appropriate conversion.
       7
       8      access q1vars;          $ access global q1 variables.
       9      access nscod;           $ access variables global to cod.
      10
      11      if fm1 = f_uint then
      12          call set_a1(f_int, no);
      13          call emconv(sym_t1_, a1, f_int, no);
      14
      15      elseif fm1 = f_ureal then
      16          call set_a1(f_real, no);
      17          call emconv(sym_t1_, a1, f_real, no);
      18      end if;
      19
      20      return;
      21
      22      end subr typea1;
       1 .=member typea2
       2      subr typea2;
       3
       4$ this routine is called before emitting a q2 instruction which
       5$ might pass a2 to the run time library. it checks that a2 is
       6$ a typed quantity; if not it makes the appropriate conversion.
       7
       8      access q1vars;          $ access global q1 variables.
       9      access nscod;           $ access variables global to cod.
      10
      11      if fm2 = f_uint then
      12          call set_a2(f_int, no);
      13
      14      elseif fm2 = f_ureal then
      15          call set_a2(f_real, no);
      16      end if;
      17
      18      return;
      19
      20      end subr typea2;
       1 .=member typea3
       2      subr typea3;
       3
       4$ this routine is called before emitting a q2 instruction which
       5$ might pass a3 to the run time library. it checks that a3 is
       6$ a typed quantity; if not it makes the appropriate conversion.
       7
       8      access q1vars;          $ access global q1 variables.
       9      access nscod;           $ access variables global to cod.
      10
      11      if fm3 = f_uint then
      12          call set_a3(f_int, no);
      13
      14      elseif fm3 = f_ureal then
      15          call set_a3(f_real, no);
      16      end if;
      17
      18      return;
      19
      20      end subr typea3;
       1 .=member typea4
       2      subr typea4;
       3
       4$ this routine is called before emitting a q2 instruction which
       5$ might pass a4 to the run time library.  it checks that a4 is
       6$ a typed quantity; if not it makes the appropriate conversion.
       7
       8      access q1vars;          $ access global q1 variables.
       9      access nscod;           $ access variables global to cod.
      10
      11      if fm4 = f_uint then
      12          call set_a4(f_int, no);
      13
      14      elseif fm4 = f_ureal then
      15          call set_a4(f_real, no);
      16      end if;
      17
      18
      19      end subr typea4;
       1 .=member emdebug
       2      subr emdebug;
       3
       4$ this routine emits the various run time debugging operations. we
       5$ simply look up a1 in a table 'debug_ops'.
       6
smfa 171      size spec(hs);          $ specifier to build run-time names entry
smfa 172
       7      +*  debug_op(op) = a_debug_op(op - sym_cdebug_max)  **
       8
       9      size a_debug_op(ps);
      10      dims a_debug_op(sym_debug_max - sym_cdebug_max);
      11
      12      data debug_op(sym_rtre0)  = q2_notre:
      13           debug_op(sym_rtre1)  = q2_tre:
      14           debug_op(sym_rtrc0)  = q2_notrc:
      15           debug_op(sym_rtrc1)  = q2_trc:
      16           debug_op(sym_rtrg0)  = q2_notrg:
      17           debug_op(sym_rtrg1)  = q2_trg:
      18           debug_op(sym_rgcd0)  = q2_nogdump:
      19           debug_op(sym_rgcd1)  = q2_gdump:
      20           debug_op(sym_rdump)  = q2_dump:
      21           debug_op(sym_rgarb)  = q2_garb;
      22
      23      access q1vars;          $ access global q1 variables.
      24      access nscod;           $ access variables global to cod.
      25
      26
      27      if op = q1_trace then
      28          if a1 = sym_calls then
      29              call em2(q2_trccalls, address(sym_one), 0, 0);
      30          elseif a1 = sym_stmts then
      31              call em2(q2_trcstmts, address(sym_one), 0, 0);
      32          else
      33              call em2(q2_trcsym, addr_a1, address(sym_one), 0);
      34          end if;
      35
      36      elseif op = q1_notrace then
      37          if a1 = sym_calls then
      38              call em2(q2_trccalls,  address(sym_zero), 0, 0);
      39          elseif a1 = sym_stmts then
      40              call em2(q2_trcstmts,  address(sym_zero), 0, 0);
      41          else
      42              call em2(q2_trcsym, addr_a1,  address(sym_zero), 0);
      43          end if;
      44
      45      else
      46      if a1 > sym_cdebug_max then
      47          call em2(debug_op(a1), 0, 0, 0);
      48
      49      else
      50          go to case(a1) in sym_cdebug_min to sym_cdebug_max;
      51
      52          /case(sym_cq1cd)/   $ q1 code dump --- already done
      53
      54              go to esac;
      55
      56
      57          /case(sym_cq1sd)/   $ q1 symbol table dump
      58
      59              call sdump;
      60              go to esac;
      61
      62
      63          /case(sym_cq2cd)/   $ q2 code dump
      64
      65$ note that the routine q2dump assumes that it is called after the
      66$ routine termcode has been executed.  at this point, the length of
      67$ the current code block has not been filled in yet, so start by
      68$ setting codenw to the current value.
      69
      70              codenw(code_org) = h_const - code_org;
smfa 173              get_addr(s_rnames, sym_rnames);
smfa 174              build_spec(spec, t_tuple, rnames); heap(s_rnames) = spec;
      71
      72              call q2dump;
      73              go to esac;
      74
      75
      76          /esac/
      77
      78      end if;
      79
      80      end if;
      81
      82
      83      end subr emdebug;
       1 .=member initcode
       2      subr initcode;
       3
       4$ this routine is called before the start of actual code generation.
       5$ allocate a data block for the code for this routine and
       6$ initialize it.
       7
       8      access q1vars;          $ access global q1 variables.
       9      access nscod;           $ access variables global to cod.
      10
      11
      12      get_code(hl_code, code_org);
      13      htype(code_org) = h_code;
      14      hlink(code_org) = 0;
      15
      16      $ point to the 'zero-th' instruction
      17      codep = code_org + hl_code - inst_nw;
      18
      19$ reset cstmt_count to its value at the start of the unit.
      20      cstmt_count = ustmt_count;
      21
      22
      23      end subr initcode;
       1 .=member em2
       2      subr em2(opc, v1, v2, v3);
       3
       4$ this routine emits a q2 instruction. we do this by extending the
       5$ current code block and setting its fields.
       6
       7
       8      size opc(ps),  $ op code
       9           v1(ps),   $ operands
      10           v2(ps),
      11           v3(ps);
      12
      13      access q1vars;          $ access global q1 variables.
      14      access nscod;           $ access variables global to cod.
      15
      16      get_code(inst_nw, codep);
      17
      18      codeop(codep) = opc;
      19      codea1(codep) = v1;
      20      codea2(codep) = v2;
      21      codea3(codep) = v3;
      22
      23
      24      end subr em2;
       1 .=member sa4
       2      subr sa4(v);
       3
       4$ this routine sets codea4 of the current quadruple
       5
       6      size v(ps);
       7
       8      access q1vars;          $ access global q1 variables.
       9      access nscod;           $ access variables global to cod.
      10
      11      codea4(codep) = v;
      12
      13
      14      end subr sa4;
       1 .=member termcode
       2      subr termcode;
       3
       4$ this routine is called when we finish generating code for a
       5$ procedure. we fill in the length of the code block.
       6
smfa 175      size spec(hs);          $ specifier to build run-time names entry
smfa 176
       7      access q1vars;          $ access global q1 variables.
       8      access nscod;           $ access variables global to cod.
       9
      10      if (h_const > max_code_address)
      11         call abort('addressability exceeded');
      12
      13      codenw(code_org) = codep + inst_nw - code_org;
      14
      15      code_tot = code_tot + codenw(code_org);
      16
      17$ dump code for this routine if desired
smfa 177      if q2cd_flag then
smfa 178          get_addr(s_rnames, sym_rnames);
smfa 179          build_spec(spec, t_tuple, rnames); heap(s_rnames) = spec;
smfa 180          call q2dump;
smfa 181      end if;
      19
      20$ zero code_org and codep. this indicates to the dump routines
      21$ that we are not currently generating code.
      22      code_org = 0;
      23      codep    = 0;
      24
      25
      26      end subr termcode;
       1 .=member uselab
       2      subr uselab(lab);
       3
       4$ this routine is called after generating a q2 instruction which
       5$ uses a label.
       6
       7$ if the label has been defined, we merely return. otherwise
       8$ we build a chain of all the forward references to the label.
       9$ this chain starts in the labels 'labval' field and threads
      10$ the codea1 fields of the instructions which use it.
      11
      12      size lab(ps);  $ symtab pointer for label
      13
      14      access q1vars;          $ access global q1 variables.
      15      access nscod;           $ access variables global to cod.
      16
      17
      18      if (is_ldef(lab)) return;
      19
      20      codea1(codep) = labval(lab);
      21
      22      if (codep > max_code_address)
      23          call abort('label address too big for labval in uselab');
      24      labval(lab) = codep;
      25
      26
      27      end subr uselab;
       1 .=member setlab
       2      subr setlab(lab);
       3
       4$ this routine is called whenever a procedure or label is
       5$ defined. we adjust all forward references to the label.
       6$
       7$ if 'lab' is a procedure then we have just initialized a new
       8$ code block, and codep points to its header.
       9$
      10$ if 'lab' is a label then we are in the middle of a code block
      11$ and codep points to the previous instruction.
      12
      13
      14      size lab(ps);  $ label
      15
      16      size p(ps),  $ code pointer
      17           p1(ps),  $ code pointer
      18           lval(ps); $ final value of label
      19
      20      access q1vars;          $ access global q1 variables.
      21      access nscod;           $ access variables global to cod.
      22
      23
      24$
      25$ find the value of the label
      26$
      27      if symtype(lab) = f_proc then
      28          lval = code_org + hl_code;
      29      else
      30          lval = codep + inst_nw;
      31      end if;
      32
      33      if (lval > max_code_address)
      34          call abort('label address too big for labval in setlab');
      35$
      36$ adjust forward references
      37$
      38      p = labval(lab);  $ head of chain
      39
      40      while p ^= 0;
      41          p1 = codea1(p);
      42          codea1(p) = lval;
      43          p = p1;
      44      end while;
      45
      46      labval(lab)  = lval;
      47      is_ldef(lab) = yes;
      48
      49
      50      end subr setlab;
       1 .=member setlab1
       2      subr setlab1;
       3
       4$ this routine is called after we have seen all the units in the
       5$ compilation. it processes all labels which are still undefined.
       6
       7$ the semantic pass catches most cases of undefined labels. there is
       8$ only one case which must be handled by the code generator:
       9
      10$ the symbol table entries for exported procedures are built when
      11$ we compile the directory. the semantic pass writes out the table
      12$ entries for the directory before we know whether the exported procedur
      13$ are included in the compilation. there is no way for the semantic
      14$ pass to diagnose unsatisfied references to exported procedures.
      15
      16$ if a compilation contains a directory, then the directory is still
      17$ in core at the end of compilation. missing external procedures are
      18$ the only symbol table entries with:
      19
      20$ is_ldef:     no
      21$ labval:      non-zero
      22
      23$ the labval field of these entries contains the head of a list of
      24$ calls to the procedure.
      25
      26$ we find all such calls and change their opcodes to q2_ucall(call
      27$ unsatisfied external).
      28
      29      size i(ps),      $ symtab index
      30           p(ps),      $ q2 pointer
      31           p1(ps);     $ q2 pointer
      32
      33      access q1vars;          $ access global q1 variables.
      34      access nscod;           $ access variables global to cod.
      35
      36      do i = 1 to symtabp;
      37          if (is_ldef(i) ! labval(i) = 0) cont;
      38
      39          call codwrn(01, i);
      40
      41          p = labval(i);  $ first reference to label
      42
      43          while p ^= 0;
      44              p1 = codea1(p);    $ next reference
      45
      46              codeop(p) = q2_ucall;
      47              codea1(p) = 0;
      48
      49              p = p1;
      50          end while;
      51      end do;
      52
      53      end subr setlab1;
       1 .=member inienv1
       2      subr inienv1;
       3
       4$ this is the first of several routines used to build the heap. it
       5$ is called at the start of code generation, before we generate
       6$ code for the first procedure.
       7
       9
      10      access q1vars;          $ access global q1 variables.
      11      access nscod;           $ access variables global to cod.
      12
      13
      14$
      15$ we assume a minimum heap size of 1024 words, and assume that
      16$ if h_lim is less than this value, it specifies the heap size in
      17$ kilo-words.
      18$
      19      if (0 < h_lim & h_lim < 1024) h_lim = h_lim * 1024;
      20
      21      if (h_lim = 0) h_lim = default_h;
      22
      23      call getspace(h_lim, yes);
      24$
      25$ the same assumption is made for the constant area size parameter.
      26$ if we obtain an unreasonable value, we reset it to the minimum of
      27$ h_lim/2 and dafault_ca.
      28$
      29      if (0 < ca_lim & ca_lim < 1024)  ca_lim = ca_lim * 1024;
      30
      31      if ca_lim = 0 ! ca_lim > h_lim then
      32          ca_lim = h_lim / 2;
      33          if (ca_lim > default_ca) ca_lim = default_ca;
      34      end if;
      35$
      36$ try to find some reasonable estimate for the run-time symbol table
      37$ size
      38$
      39      if (0 < sym_lim & sym_lim < 1024) sym_lim = sym_lim * 1024;
      40
      41      if sym_lim = 0 ! sym_lim > max_symtab then
      42          sym_lim = h_lim / 8;
      43          if (sym_lim > default_sym) sym_lim = default_sym;
      44      end if;
      45$
      46$ print final values of h and ca in phase heading
      47$
sunb  39      if lcp_flag then  $ continue phase heading
sunb  40          put ,'symbol table size: st = '    :sym_lim    ,i ,'. '
sunb  41              ,'constants area size: ca = '  :ca_lim     ,i ,'. ' ,skip
sunb  42              ,'initial heap size: h = '     :h_lim      ,i ,'. ' ,skip;
sunb  43      end if;
      52$
      53$ set the global heap pointers
      54$
      55      h = 1;   t = h_lim + 1;
      56
smfa 182      get_heap(sym_lim, snam_org);
      58      snam_end = h - 1;
      59
      60      get_heap(sym_lim, sym_org);
      61      sym_end = h - 1;   sym_lim = h;
      62
      63      get_heap(ca_lim, ca_org);
smfa 183      h_const = ca_org;  h_org   = h;
      65
      66      if (sym_end > max_symtab)
      67          call abort('symbol table addressability exceeded');
      68
      69
      70      end subr inienv1;
       1 .=member inienv2
       2      subr inienv2;
       3
       4$ this routine initializes all constants and static variables in
       5$ the current scope. this is done in three steps:
       6
       7$ 1. reassign new ft_pos values to all packed local maps to
       8$    allow for optimal packing.
       9
      10$ 2. iterate over all the forms in this scope, calling 'insamp'
      11$    to build their standard omegas.
      12
      13$    note that certain types such as f_lset do not have sample
      14$    values, so these values are not initialized.
      15
      16$ 3. iterate over all symbols in this scope. set each static
      17$    variable to the proper omega, and build the value for
      18$    each constant.
      19
      20$    note that we donot initialize temporaries since they will
      21$    always be used before they are defined.
      22
      23
      24      size j(ps),   $ loop index
      25           addr(ps);  $ address
      26
      27      access q1vars;          $ access global q1 variables.
      28      access nscod;           $ access variables global to cod.
      29
      30
      31      call optpack;  $ do optimal packing
      32
      33      do j = formtab_org+1 to formtabp;
      34          if (ft_samp(j) ^= 0) call insamp(j);
      35      end do;
      36
      37      do j = symtab_org+1 to symtabp;
      38          if ( ^ is_store(j)) cont;
      39
      40          heap(address(j)) = heap(ft_samp(form(j)));
      41
      42          if (vptr(j) ^= 0) call incnst(j);
      43      end do;
      44
      45
      46      end subr inienv2;
       1 .=member optpack
       2      subr optpack;
       3
       4$ this routine does optimal packing for local objects.
       5
       6
       7      size base(ps);          $ pointer to current base
       8      size f1(ps);            $ pointer to current local object
       9      size tp(ps);            $ ft_type of f1
      10      size f2(ps);            $ pointer to packed range
      11
      12      size lsw(ps);           $ value for ls_word
      13      size lsb(ps);           $ value for ls_bit
      14      size lsw0(ps);          $ initial value for lsw
      15      size bits(ps);          $ number of bits for packed object
      16
      17      size j(ps);             $ index
      18      size k(ps);             $ current parent
      19      size m(ps);             $ child to be promoted
      20      size lson(ps);          $ left child of current parent
      21      size rson(ps);          $ right child of current parent
      22      size n(ps);             $ number of packed objects
      23
      24      size aux_bits(ps);
      25      dims aux_bits(2*ft_num_max);
      26
      27      size aux_form(ps);
      28      dims aux_form(2*ft_num_max);
      29
      30      access q1vars;          $ access global q1 variables.
      31      access nscod;           $ access variables global to cod.
      32
      33
      34      do base = formtab_org+1 to formtabp;
      35          if (^ is_fbase(base))  cont do base;
      36          if (ft_samp(base) = 0) cont do base;
      37          assert base > f_max;
      38
      39          if ft_type(base) = f_pbase then
      40              lsw0 = hl_latom - 1;
      41          else
      42              lsw0 = hl_ebb - 1;
      43          end if;
      44
      45          n = 0;
      46
      47          do f1 = base to formtabp;
      48              if (^ is_floc(f1))       cont do f1;
      49              if (ft_pos(f1) = 0)      cont do f1;
      50              if (ft_base(f1) ^= base) cont do f1;
      51
      52              tp = ft_type(f1);
      53
      54              if tp = f_lset then
      55                  bits = 1;
      56
      57              elseif tp = f_lpmap then
      58                  f2 = ft_im(f1);
      59                  if (ft_type(f2) = f_elmt) f2 = ft_base(f2);
      60
      61                  bits = .fb. ft_lim(f2);
      62
      63              else
      64
      65                  lsw = lsw0;
      66
      67                  do j = f_lmap to tp - 1;
      68                      lsw = lsw + ft_num(base, j);
      69                  end do;
      70
      71                  ft_pos(f1) = lsw + ft_pos(f1);
      72                  ft_bit(f1) = 1;
      73
      74                  cont do f1;
      75              end if;
      76
      77              n = n + 1;
      78              aux_form(n) = f1;
      79              aux_bits(n) = bits;
      80          end do f1;
      81
      82          $ next we sort the packed local maps, using heap sort
      83          do j = n/2 to 1 by -1;
      84              k = j;   lson = k + k;
      85              while lson <= n;
      86                  if lson < n then
      87                      rson = lson + 1;
      88                      if aux_bits(lson) < aux_bits(rson) then
      89                          m = rson;
      90                      else
      91                          m = lson;
      92                      end if;
      93                  else
      94                      m = lson;
      95                  end if;
      96
      97                  if aux_bits(k) < aux_bits(m) then
      98                      swap(aux_bits(k), aux_bits(m));
      99                      swap(aux_form(k), aux_form(m));
     100                      k = m;   lson = k + k;
     101                  else
     102                      quit while lson;
     103                  end if;
     104              end while lson;
     105          end do;
     106
     107          lsw = lsw0 + 1;
     108          lsb = 1;
     109
     110          do j = f_lmap to f_lrmap;
     111              lsw = lsw + ft_num(base, j);
     112          end do;
     113
     114          j = n;
     115          while j >= 1;
     116              k = 1;
     117              while k <= j;
     118                  if lsb + aux_bits(k) > hs + 1 then
     119                      k = k + 1;   cont while k;
     120                  end if;
     121
     122                  ft_pos(aux_form(k)) = lsw;
     123                  ft_bit(aux_form(k)) = lsb;
     124                  lsb = lsb + aux_bits(k);
     125
     126                  aux_bits(k) = aux_bits(j);
     127                  aux_form(k) = aux_form(j);
     128                  j = j - 1;
     129
     130                  lson = k + k;
     131                  while lson <= j;
     132                      if lson < j then
     133                          rson = lson + 1;
     134                          if aux_bits(lson) < aux_bits(rson) then
     135                              m = rson;
     136                          else
     137                              m = lson;
     138                          end if;
     139                      else
     140                          m = lson;
     141                      end if;
     142
     143                      if aux_bits(k) < aux_bits(m) then
     144                          swap(aux_bits(k), aux_bits(m));
     145                          swap(aux_form(k), aux_form(m));
     146                          k = m;   lson = k + k;
     147                      else
     148                          quit while lson;
     149                      end if;
     150                  end while;
     151
     152                  cont while j >= 1;
     153              end while k;
     154
     155              lsw = lsw + 1;   lsb = 1;
     156          end while j >= 1;
     157
     158          if lsb = 1 then
     159              ft_bit(base) = lsw;
     160          else
     161              ft_bit(base) = lsw + 1;
     162          end if;
     163
     164      end do base;
     165
     166
     167      if (q1sd_flag) call fmdump;
     168      end subr optpack;
       1 .=member inienv3
       2      subr inienv3;
       3
       4$ this routine completes the initialization of the environment
       5$ after the entire program has been compiled.
       6
       7
       8      size j(ps),             $ loop index
       9           addr(ps),          $ address
      10           spec(hs),          $ specifier
      11           gapn(ps);          $ size of gap between h_const and h_org
      12      size ss1(ssz);          $ global string specifier
      13
      14      size nulltup(hs);       $ returns specifier for null tuple
      15      size nulllc(ssz);       $ returns string specifier for null string
      16
      17      access q1vars;          $ access global q1 variables.
      18      access nscod;           $ access variables global to cod.
      19
      20$ the array type_syms maps type codes t_xxx into the symbol entries
      21$ for '.atom', etc.
      22
      23      defzero(type_syms, a_type_syms);
      24
      25      size a_type_syms(ps);
      26      dims a_type_syms(t_lmax + 1);
      27
      28      data type_syms(t_int)    =  sym_int:
      29           type_syms(t_string) =  sym_string:
      30           type_syms(t_atom)   =  sym_atom:
      31           type_syms(t_error)  =  sym_om:
      32           type_syms(t_proc)   =  sym_om:
      33           type_syms(t_lab)    =  sym_om:
      34           type_syms(t_latom)  =  sym_atom:
      35           type_syms(t_elmt)   =  sym_om:
      36           type_syms(t_lint)   =  sym_int:
      37           type_syms(t_istring)=  sym_string:
      38           type_syms(t_real)   =  sym_real:
      39           type_syms(t_tuple)  =  sym_tuple:
      40           type_syms(t_stuple) =  sym_tuple:
      41           type_syms(t_set)    =  sym_set:
      42           type_syms(t_map)    =  sym_set:
      43           type_syms(t_skip)   =  sym_om;
      44
      45$ allocate a tuple to store the run time statistics
      46
      47$ note that the second argument to 'nulltup' is the expected nelt of
      48$ the tuple; nulltup adds a breath factor of 1/3 to this before
      49$ allocating the tuple. since the tuple for keeping statistic will never
      50$ grow, there is no need for this breath space. we request less space
      51$ than we will actually need so that it comes out correct when the
      52$ breath space is added.
      53
      54
      55      if st_no > 0 then
      56          addr       = address(sym_stat);
      57          heap(addr) = nulltup(f_ituple, (2*st_no*st_max+2)/3 );
      58
      59          nelt(value(addr)) = st_no + 1;
      60      end if;
      61
      62$ at this point we have set all the environment parameters except
      63$ savet and codep. we begin by setting them.
      64
      65      savet = t;
      66      codep = labval(sym_main_);
      67      sym_org  = sym_lim;
smfa 184      snam_org = snam_end - (sym_end-sym_org);
      69
      70      if (codep = 0) call ermsg(23, 0);
      71
      72$ if there is extra space in the constants area then we will
      73$ adjust h_org and let the extra space be reclaimed during the
      74$ first garbage collection.
      75
      76$ if we adjust h_org we must reformat the extra space to look like
      77$ a valid heap block. we format it as a real tuple.
      78
      79
      80      gapn = h_org - h_const;
      81      if (gapn > max_nelt) call abort('constant area too large.');
      82
      83      if gapn > talloc(0) then $ build tuple
      84          htype(h_const)   = h_rtuple;
      85          hform(h_const)   = f_rtuple;
      86          nelt(h_const)    = 0;
      87          maxindx(h_const) = gapn - (hl_tuple + 1);
      88
      89          h_org            = h_const;
      90          h_const          = h_const + hl_tuple;
      91      end if;
smfa 185
smfa 186$ likewise we truncate the last run-time names string block.
smfa 187
smfa 188      ss1  = value_ tcomp(rnames, nelt(rnames));
smfa 189      addr = ss_ptr(ss1);
smfa 190      gapn = lc_nwords(addr) - lcalloc(ss_len(ss1));
smfa 191      if gapn > talloc(0) then  $ build tuple.
smfa 192          lc_nwords(addr) = lc_nwords(addr) - gapn;
smfa 193          addr = addr + lc_nwords(addr);
smfa 194          htype(addr) = h_rtuple; hlink(addr) = 0;
smfa 195          hform(addr) = f_rtuple;
smfa 196          nelt(addr) = 0; maxindx(addr) = gapn - (hl_rtuple + 1);
smfa 197          is_hashok(addr) = no; is_neltok(addr) = no;
smfb 332          h_names1 = addr + hl_rtuple; h_names2 = addr + tuplen(addr);
smfa 198      end if;
      92
      93$ save the adresses various symbol table entries.
      94
      95      get_addr(s_true,    sym_true);
      96      get_addr(s_false,   sym_false);
      97      get_addr(s_okval,   sym_okval);
      98      get_addr(s_fid,     sym_fid);
      99      get_addr(s_free,    sym_free);
     100      get_addr(s_fmax,    sym_fmax);
     101      get_addr(s_fmode,   sym_fmode);
     102
     103      get_addr(s_io1,     sym_io1);
     104      get_addr(s_io2,     sym_io2);
     105
     106      get_addr(s_stat,    sym_stat);
     107
     108      get_addr(s_ss1,         sym_ss1);
     109      get_addr(s_ss2,         sym_ss2);
     110
     111      build_spec(ss1, t_istring, nulllc(0));   heap(s_ss1) = ss1;
     112      build_spec(ss1, t_istring, nulllc(0));   heap(s_ss2) = ss1;
     113
     114      get_addr(s_ovar,    sym_ovar);
     115      get_addr(s_scopes,  sym_scopes);
     116      get_addr(s_rnspec,  sym_rnspec);
     117      get_addr(s_rnames,  sym_rnames);
smfa 199      build_spec(spec, t_tuple, rnames); heap(s_rnames) = spec;
     118
     119      get_addr(s_intf,    sym_intf);
     120      heap(s_intf) = nulltup(f_tuple, 0);
     121
     122$    prepare other heap entries for expansion symbols
     123
     124      get_addr(s_spare2, sym_spare2);
     125      get_addr(s_spare3, sym_spare3);
     126      get_addr(s_spare4, sym_spare4);
     127      get_addr(s_spare5, sym_spare5);
     128      get_addr(s_spare6, sym_spare6);
     129      get_addr(s_spare7, sym_spare7);
     130      get_addr(s_spare8, sym_spare8);
     131      get_addr(s_spare9, sym_spare9);
     132      get_addr(s_sparea, sym_sparea);
     133      get_addr(s_spareb, sym_spareb);
     134      get_addr(s_sparec, sym_sparec);
     135      get_addr(s_spared, sym_spared);
     136      get_addr(s_sparee, sym_sparee);
     137      get_addr(s_sparef, sym_sparef);
     138      get_addr(s_spareg, sym_spareg);
     139      get_addr(s_spareh, sym_spareh);
     140      get_addr(s_sparei, sym_sparei);
     141      get_addr(s_sparej, sym_sparej);
     142      get_addr(s_sparek, sym_sparek);
     143
     146$ build the map s_types from type codes to addresses of type
     147$ constants.
     148
     149      do j = t_min to t_lmax;
     150          if type_syms(j) = sym_om then
     151              s_types(j) = ft_samp(f_string);
     152          else
     153              get_addr(s_types(j), type_syms(j));
     154          end if;
     155      end do;
     156
     157$ process undefined types
     158      do j = t_lmax+1 to t_max;
     159          s_types(j) = ft_samp(f_string);
     160      end do;
     161
     162      $ 's_types' has one additonal entry, which holds the
     163      $ string 'boolean'.
     164      get_addr(s_types(t_max+1), sym_bool);
     165
     166$ initialize run time io
     167      call initio;
smfb 333
smfb 334      $ initialise the setl debugger if requested
smfb 335      if (debug_flag) call inidbg;
     168
     169
     170      end subr inienv3;
       1 .=member insamp
       2      subr insamp(fm);
       3
       4$ this routine builds a sample value for a form 'fm'. sample
       5$ values are defines as follows:
       6
       7$ if fm is 'base(mode)' then the sample value is a null base.
       8$ otherwise the sample value is an omega of the proper type.
       9
      10$ omega values are just like any other values except that their
      11$ is_om bits are set. this means that omegas can take up an
      12$ arbritrarily large amount of storage. when we build an omega
      13$ for use as a sample value, we always build the smallest
      14$ possible omega for that type.
      15
      16$ the representation of a standard omega is a function of its
      17$ type:
      18
      19$ short types:
      20
      21$ for all short types the minimal omega is a specifier
      22$ with the proper type code and a value of zero.
      23
      24$ strings:
      25
      26$ the omega for an indirect string is a specifier with:
      27
      28$ type:   indicates t_oistring
      29$ value:  string specifier for null string
      30
      31$ tuples:
      32
      33$ the omega for a tuple is a specifier with:
      34
      35$ type:   indicates t_otuple
      36$ value:  pointer to null tuple
      37
      38$ for mixed tuples the null tuple has a maxindx equal to
      39$ the length of the tuple; otherwise it has maxindx of 1.
      40
      41$ sets, maps, and bases
      42
      43$ the omega for a set, map or base is a specifier with:
      44
      45$ type:   indicates t_oset, etc.
      46$ value:  pointer to null set, etc.
      47
      48$ the null set has lognhedrs = 0.
      49
      50$ the sample values for sets, tuples, and bases are allocated in
      51$ the dynamic part of the heap, while long strings, ints, and reals
      52$ are allocated in the constants area.
      53
      54      size fm(ps);            $ form to be processed
      55
      56      size tp(ps);            $ ft_type
      57      size spec(hs);          $ specifier for sample value
      58      size p(ps);             $ heap pointer
      59      size n(ps);             $ number of tuple elements
      60      size tup_form(ps);      $ tuple form
      61      size ebsz(ps);          $ size of ebs
      62      size sz(ps);            $ block size
      63      size nl(ps);            $ nlmaps
      64      size im(hs);            $ map image
      65      size mapc(ps);          $ map code ft_xxx
      66      size base(ps);          $ pointer to base
      67      size om_val(hs);        $ omega value
      68      size j(ps);             $ loop index
      69      size ht(ps);            $ pointer to hash table
      70      size tmp(ps);           $ pointer to template
      71      size lsw(ps);           $ ls_word value
      72      size lsb(ps);           $ ls_bit value
      73      size bits(ps);          $ number of bits for packed object
      74      size vals(ps);          $ number of values for packed tuple
      75      size key_val(hs);       $ value of key for packed tuples
      76      size key_addr(ps);      $ address of key
      77      size elmt(hs);          $ specifier for element
      78      size p1(ps);            $ heap pointer
      79      size p2(ps);            $ heap pointer
      80
      81      size nulllc(ssz);       $ returns null string
      82      size getht(ps);         $ gets hash table
      83
      84      access q1vars;          $ access global q1 variables.
      85      access nscod;           $ access variables global to cod.
      86
      87
      88$ begin by initializing a specifier 'spec' with the proper
      89$ type code, etc. then jump on its type to fill in its value.
      90
      91$ note that omegas always have their share bits set. this way if the
      92$ programmer tries to use them destructively, we will enter the copy
      93$ routine and abort.
      94
      95      tp = ft_type(fm);
      96
      97      build_spec(spec, tmap(tp), 0);  $ initialize specifier
      98      is_shared_ spec = yes;
      99
     100      go to case(tp) in f_min to f_max;
     101
     102/case(f_gen)/    $ general
     103
     104      go to esac;
     105
     106/case(f_sint)/        $ short int
     107
     108      value_ spec = ft_low(fm);
     109      go to esac;
     110
     111/case(f_sstring)/      $ short chars
     112
     113/case(f_atom)/       $ short atom
     114
     115      go to esac;
     116
     117
     118/case(f_latom)/      $ 'long' atom
     119
     120$ strangely enough, we should never reach this label. the only
     121$ objects stored as long atoms are elements of plex bases; their
     122$ form always indicates f_elmt.
     123
     124      go to bad_type;
     125
     126/case(f_elmt)/       $  element
     127
     128      base = ft_base(fm);           $ form of base
     129      p1   = value(ft_samp(base));   $ pointer to base
     130
     131      if ft_type(base) = f_base then
smfd 177          p1 = template(p1);
     134
     135      else   $ plex base
smfd 178          otype_ spec = t_olatom;
     137      end if;
smfd 179      value_ spec = p1;
smfd 180
     138
     139      go to esac;
     140
     141/case(f_int)/
     142
mjsa  10      spec = putintli(om_int);
mjsa  11      is_shared_ spec = yes;
     152      go to esac;
     153
     154
     155/case(f_string)/
     156
     157      value_ spec = nulllc(0);
     158      go to esac;
     159
     160/case(f_real)/       $ real
     161
     162      get_const(real_nw, p);
     163
     164      htype(p) = h_real;
     165      hlink(p) = 0;
     166      rval(p)  = om_real;
     167
     168      value_ spec = p;
     169
     170      go to esac;
     171
     172/case(f_uint)/  $ untyped int
     173
     174      spec = om_int;
     175      go to esac;
     176
     177/case(f_ureal)/ $ untyped real
     178
     179      spec = om_real;
     180      go to esac;
     181
     182/case(f_tuple)/      $ standard tuple
     183
     184/case(f_ituple)/
     185
     186/case(f_rtuple)/
     187
     188      n = 1;   $ number of elements for tuple
     189      if (ft_lim(fm) ^= 0) n = ft_lim(fm);
     190
     191      get_heap(talloc(n), p);
     192
     193      htype(p)    = htmap(tp);
     194      hlink(p)    = 0;
     195
     196      hform(p)    = fm;
     197
     198      maxindx(p)  = n;
     199      is_range(p) = no;
     200
     201      set_nelt(p, 0);
     202      set_hash(p, hc_tuple);
     203
     204      om_val = heap(ft_samp(ft_elmt(fm)));
     205
     206      do j = 0 to n;
     207          tcomp(p, j) = om_val;
     208      end do;
     209
     210      value_ spec = p;
     211
     212      go to esac;
     213
     214
     215/case(f_ptuple)/     $ packed tuple
     216
     217      n = 1;   $ number of elements for tuple
     218      if (ft_lim(fm) ^= 0) n = ft_lim(fm);
     219
     220$ get packing information. if this is a packed tuple of ints, then
     221$ packinfo will set:
     222
     223$ key_val:     value of pt_key field
     224$ key_addr:    0
     225
     226$ we will simply store key_val.
     227
     228$ if this is a packed tuple of elements of b then packinfo will set:
     229
     230$ key_val:    0
     231$ key_addr:   address of symbol table entry for key
     232
     233$ the key itself will not be available until the base is
     234$ initialized, so we will build a list of the heap words which need
     235$ the key.
     236
     237      call packinfo(bits, vals, key_val, key_addr, fm);
     238
     239      sz = (n-1)/vals + 1 + hl_ptuple;
     240      get_heap(sz, p);
     241
     242      htype(p)   = h_ptuple;
     243      hlink(p)    = 0;
     244
     245      hform(p)   = fm;
     246
     247      maxindx(p) = n;
     248      is_range(p) = no;       $ should never be tested
     249
     250      ptbits(p)  = bits;
     251      ptvals(p)  = vals;
     252
     253      if key_addr = 0 then
     254          ptkey(p) = key_val;
     255      else
     256          ptkey(p)       = heap(key_addr);
     257          heap(key_addr) = p + off_ptkey;
     258      end if;
     259
     260      set_nelt(p, 0);
     261      set_hash(p, hc_tuple);
     262
     263      do j = 0 to n;
     264          pcomp(p, j) = 0;    $ nb. zero corresponds to omega
     265      end do;
     266
     267      value_ spec = p;
     268
     269      go to esac;
     270
     271
     272/case(f_mtuple)/     $ mixed tuple
     273
     274      n = ft_lim(fm);
     275
     276      get_heap(talloc(n), p);
     277
     278      htype(p) = h_tuple;
     279      hlink(p) = 0;
     280
     281      hform(p) = fm;
     282
     283      maxindx(p) = n;
     284      is_range(p) = no;       $ should never be tested
     285
     286      set_nelt(p, 0);
     287      set_hash(p, hc_tuple);
     288
     289      tcomp(p, 0) = heap(ft_samp(f_gen));
     290
     291      p1 = ft_elmt(fm);   $ mttab pointer
     292
     293      do j = 1 to n;
     294          tcomp(p, j) = heap(ft_samp(mttab(p1+j)));
     295      end do;
     296
     297      value_ spec = p;
     298
     299      go to esac;
     300
     301/case(f_uset)/       $ standard set
     302
     303      get_heap(hl_uset, p);   $ build set header
     304
     305      htype(p) = h_uset;
     306      hlink(p) = 0;
     307      hform(p) = fm;
     308
     309      is_based(p) = no;
     310      is_elset(p) = no;
     311      is_map(p)   = no;
     312      is_smap(p)  = no;
     313      is_mmap(p)  = no;
     314
     315      if (ft_type(ft_elmt(fm)) = f_elmt) is_elset(p) = yes;
     316
     317      set_nelt(p, 0);
     318      set_hash(p, hc_set);
     319
     320      ebsz = hl_eb + 1;
     321      hashtb(p) = getht(ebsz, h_ebs);  $ get hash table
     322
     323$ store omegas in eb-s.
     324      ebspec(template(p))        = heap(ft_samp(ft_elmt(fm)));
     325
     326      value_ spec = p;
     327
     328      go to esac;
     329
     330/case(f_umap)/       $ standard map
     331
     332      get_heap(hl_umap, p);   $ build set header
     333
     334      htype(p) = h_umap;
     335      hlink(p) = 0;
     336      hform(p) = fm;
     337
     338      is_based(p) = no;
     339      is_elset(p) = no;
     340      is_map(p)   = yes;
     341      is_smap(p)  = no;
     342      is_mmap(p)  = no;
     343
     344      set_nelt(p, 0);
     345      set_hash(p, hc_set);
     346
     347      ebsz = hl_eb + 2;   $ ebsize
     348      hashtb(p) = getht(ebsz, h_ebm);  $ get hash table
     349
     350$ store omegas in eb-s.
     351      ebspec(template(p))        = heap(ft_samp(ft_dom(fm)));
     352
     353      if (ft_type(ft_dom(fm)) = f_elmt) is_elset(p) = yes;
     354
     355      mapc = ft_mapc(fm);
     356      im = heap(ft_samp(ft_im(fm)));
     357
     358      if mapc = ft_smap then
     359          is_smap(p) = yes;
     360
     361      elseif mapc = ft_mmap then
     362          is_mmap(p)   = yes;
     363          is_multi_ im = yes;
     364          is_om_    im = no;
     365      end if;
     366
     367      ebimag(template(p))         = im;
     368
     369      value_ spec = p;
     370
     371      go to esac;
     372
     373/case(f_lset)/       $ local subset
     374
     375      assert fm > f_max;
     376
     377      get_heap(hl_lset, p);
     378
     379      htype(p) = h_lset;
     380      hlink(p) = 0;
     381      hform(p) = fm;
     382
     383      is_elset(p) = yes;
     384      is_based(p) = yes;
     385      is_map(p)   = no;
     386      is_smap(p)  = no;
     387      is_mmap(p)  = no;
     388
     389      set_nelt(p, 0);
     390      set_hash(p, hc_set);
     391
     392      base = value(ft_samp(ft_base(fm)));
     393
     394      if ^ is_fplex(fm) then  $ point to base
     395          tmp = template(base);
     396          hashtb(p) = hashtb(base);
     397      end if;
     398
     399$ set ls_word and ls_bit
     400
     401$ objects are stored in element blocks in the following order:
     402
     403$ 1. local maps
     404$ 2. local untyped integer maps
     405$ 3. local untyped real maps
     406$ 4. local packed maps
     407$ 5. local sets
     408
     409$ note that 1-4 correspond to the order of ft_type codes for
     410$ local maps.
     411
     412      ls_word(p) = ft_pos(fm);
     413      ls_bit(p)  = ft_bit(fm);
     414
     415      if is_fplex(fm) then
     416          .f. ls_bit(p), 1, heap(base+ls_word(p)) = 0;
     417      else
     418          .f. ls_bit(p), 1, heap(tmp+ls_word(p)) = 0;
     419      end if;
     420
     421      value_ spec = p;
     422
     423      go to esac;
     424
     425/case(f_lmap)/
     426
     427/case(f_limap)/      $ local integer map
     428
     429/case(f_lrmap)/      $ local real map
     430
     431      assert fm > f_max;
     432
     433      get_heap(hl_lset, p);
     434
     435      htype(p) = htmap(tp);
     436      hlink(p) = 0;
     437      hform(p) = fm;
     438
     439      is_elset(p) = yes;
     440      is_based(p) = yes;
     441      is_map(p)   = yes;
     442      is_smap(p)  = no;
     443      is_mmap(p)  = no;
     444
     445      set_nelt(p, 0);
     446      set_hash(p, hc_set);
     447
     448      base = value(ft_samp(ft_base(fm)));
     449
     450      if ^ is_fplex(fm) then  $ point to base
     451          tmp = template(base);
     452          hashtb(p) = hashtb(base);
     453      end if;
     454
     455      ls_word(p) = ft_pos(fm);
     456      ls_bit(p)  = ft_bit(fm);
     457
     458$ fill in image in base
     459      im = heap(ft_samp(ft_im(fm)));  $ omega image
     460
     461      mapc = ft_mapc(fm);
     462
     463      if (mapc = ft_smap) is_smap(p) = yes;
     464
     465      if mapc = ft_mmap then
     466          is_mmap(p)   = yes;
     467          is_multi_ im = yes;
     468          is_om_    im = no;
     469      end if;
     470
     471      if is_fplex(fm) then
     472          heap(base + ls_word(p)) = im;
     473      else
     474          heap(tmp + ls_word(p)) = im;
     475      end if;
     476
     477      value_ spec = p;
     478
     479      go to esac;
     480
     481
     482/case(f_lpmap)/   $ local packed map
     483
     484      assert fm > f_max;
     485
     486      get_heap(hl_lpmap, p);
     487
     488      call packinfo(bits, vals, key_val, key_addr, fm);
     489
     490      htype(p) = htmap(tp);
     491      hlink(p) = 0;
     492      hform(p) = fm;
     493
     494      is_elset(p) = yes;
     495      is_based(p) = yes;
     496      is_map(p)   = yes;
     497      is_smap(p)   = yes;
     498      is_mmap(p)  = no;
     499
     500      ls_bits(p)  = bits;
     501
     502      if key_addr = 0 then
     503          ls_key(p) = key_val;
     504      else
     505          ls_key(p)      = heap(key_addr);
     506          heap(key_addr) = p + off_ls_key;
     507      end if;
     508
     509      set_nelt(p, 0);
     510      set_hash(p, hc_set);
     511
     512      base = value(ft_samp(ft_base(fm)));
     513
     514      if ^ is_fplex(fm) then  $ point to base
     515          tmp = template(base);
     516          hashtb(p) = hashtb(base);
     517      end if;
     518
     519      ls_word(p) = ft_pos(fm);
     520      ls_bit(p)  = ft_bit(fm);
     521
     522      $ nb. a pack index of zero indicates omega
     523      if is_fplex(fm) then
     524          .f. ls_bit(p), bits, heap(base+ls_word(p)) = 0;
     525      else
     526          .f. ls_bit(p), bits, heap(tmp+ls_word(p)) = 0;
     527      end if;
     528
     529      value_ spec = p;
     530
     531      go to esac;
     532
     533/case(f_rset)/
     534
     535      assert fm > f_max;
     536
     537      $ allocate a remote set with a one-word bit string
     538      get_heap(rsalloc(rs_bpw-1), p);
     539
     540      htype(p) = h_rset;
     541      hlink(p) = 0;
     542      hform(p) = fm;
     543
     544      is_based(p) = yes;
     545      is_elset(p) = yes;
     546      is_map(p)   = no;
     547      is_smap(p)  = no;
     548      is_mmap(p)  = no;
     549
     550      rs_maxi(p) = rs_bpw - 1;
     551      rsword(p, 1) = 0;
     552
     553      set_nelt(p, 0);
     554      set_hash(p, hc_set);
     555
     556      base = value(ft_samp(ft_base(fm)));
     557      hashtb(p) = hashtb(base);
     558
     559      value_ spec = p;
     560
     561      go to esac;
     562
     563/case(f_rmap)/
     564
     565/case(f_rimap)/
     566
     567/case(f_rrmap)/
     568
     569      assert fm > f_max;
     570
     571      get_heap(hl_rmap, p);
     572
     573      htype(p) = htmap(tp);
     574      hlink(p) = 0;
     575      hform(p) = fm;
     576
     577      is_based(p) = yes;
     578      is_elset(p) = yes;
     579      is_map(p)   = yes;
     580      is_smap(p)  = no;
     581      is_mmap(p)  = no;
     582
     583      base = value(ft_samp(ft_base(fm)));
     584      hashtb(p) = hashtb(base);
     585
     586      set_nelt(p, 0);
     587      set_hash(p, 0);
     588
     589      mapc = ft_mapc(fm);
     590
     591      if (mapc = ft_smap) is_smap(p) = yes;
     592      if (mapc = ft_mmap) is_mmap(p) = yes;
     593
     594
     595$ get a pointer to the sample for the embedded tuple and copy it.
     596
     597      p1 = value(ft_samp(ft_tup(fm)));
     598
     599      sz = tuplen(p1);  $ size of tuple
     600      get_heap(sz, p2);
     601
     602      do j = 0 to sz-1;  $ copy data block
     603          heap(p2 + j) = heap(p1 + j);
     604      end do;
     605
     606$ if this is an mmap, iterate over the tuples components, clearing
     607$ their is_om bits and setting their is_multi bits.
     608
     609      if mapc = ft_mmap then
     610          do j = 0 to maxindx(p2);
     611              is_om_    tcomp(p2, j) = no;
     612              is_multi_ tcomp(p2, j) = yes;
     613          end do;
     614      end if;
     615
     616      value_ spec = p;
     617
     618      go to esac;
     619
     620
     621/case(f_rpmap)/   $ remote packed map
     622
     623      assert fm > f_max;
     624
     625      get_heap(hl_rmap, p);
     626
     627      htype(p) = htmap(tp);
     628      hlink(p) = 0;
     629      hform(p) = fm;
     630
     631      is_based(p) = yes;
     632      is_elset(p) = yes;
     633      is_map(p)   = yes;
     634      is_smap(p)   = yes;
     635      is_mmap(p)  = no;
     636
     637      base = value(ft_samp(ft_base(fm)));
     638      hashtb(p) = hashtb(base);
     639
     640      set_nelt(p, 0);
     641      set_hash(p, 0);
     642
     643$ get a pointer to the sample for the embedded tuple and copy it.
     644
     645      p1 = value(ft_samp(ft_tup(fm)));
     646
     647      sz = ptuplen(p1);  $ size of tuple
     648      get_heap(sz, p2);
     649
     650      do j = 0 to sz-1;  $ copy data block
     651          heap(p2 + j) = heap(p1 + j);
     652      end do;
     653
     654      value_ spec = p;
     655
     656      go to esac;
     657
     658
     659/case(f_pbase)/     $ plex base
     660
     661      assert fm > f_max;
     662
     663      sz = ft_bit(fm);
     664      nl = ft_num(fm, f_lmap);
     665
     666      get_heap(sz, p);
     667
     668      htype(p) = h_latom;
     669      hlink(p) = 0;
     670      la_form(p)   = fm;
     671      la_nwords(p) = sz;
     672      la_nlmaps(p) = nl;
     673
     674      value_ spec = p;
     675
     676      go to esac;
     677
     678
     679/case(f_base)/       $ base
     680
     681      assert fm > f_max;
     682
     683      get_heap(hl_base, p);   $ build set header
     684
     685      htype(p) = h_base;
     686      hlink(p) = 0;
     687      hform(p) = fm;
     688
     689      set_nelt(p, 0);
     690      set_hash(p, hc_set);
     691
     692      ebsz = ft_bit(fm);
     693      nl   = ft_num(fm, f_lmap);
     694
     695      blink(p)  = 0;
     696      rlink(p)  = 0;
     697      nlmaps(p) = nl;
     698
     699      hashtb(p) = getht(ebsz, h_ebb);
     700
     701      tmp = template(p);
     702
     703      elmt = heap(ft_samp(ft_elmt(fm)));
     704
     705      ebspec(tmp) = elmt;
     706      ebhash(tmp) = 0;
     707      ebform(tmp) = fm;
     708      ebindx(tmp) = 1;
     709
     710      if (ft_lim(fm) ^= 0) heap(ft_samp(fm)-1) = 0;
     711
     712      value_ spec = p;
     713
     714      go to esac;
     715
     716
     717/case(f_error)/    $ error
     718
     719      go to esac;
     720
     721
     722
     723
     724/case(f_lab)/  $ label
     725
     726      build_spec(spec, t_olab, 0);
     727      go to esac;
     728
     729
     730/case(f_proc)/
     731
     732      build_spec(spec, t_proc, 0);
     733      go to esac;
     734
     735
     736
     737/case(f_memb)/
     738
     739/case(f_uimap)/
     740
     741/case(f_urmap)/
     742
     743/bad_type/
     744
     745$ we reach here if objects of type 'fm' are allowed to appear in the
     746$ heap. there are two possibilities:
     747
     748$ 1. fm is one of the standard types f_xxx. we simply give it a
     749$    sample value of 0.
     750
     751$ 2. fm is something else. this indicates a compiler error.
     752
     753      if fm <= f_max then
     754          spec = 0;
     755          go to esac;
     756
     757      else
     758          call abort('insamp found illegal type');
     759      end if;
     760
     761
     762/esac/     $ end of case statement
     763
     764$ install spec and return
     765      heap(ft_samp(fm)) = spec;
     766
     767
     768      end subr insamp;
       1 .=member getht
       2      fnct getht(ebsz, ebtp);
       3
       4$ this routine builds a hash table and returns a pointer to it.
bnda  19$ the hash table has one single hash header.  the arguments to
       6$ the routine are:
       7
       8$ ebsz:     size of eb-s
       9$ ebtp:     htype of eb-s
      10
      11
bnda  20      size ebsz(ps);          $ value for element-block-size (ebsz)
bnda  21      size ebtp(ps);          $ value for heap-block-header-type (htype)
      14
bnda  22      size getht(ps);         $ pointer to hash table (returned)
      16
bnda  23      size tmp(ps);           $ pointer to template block
bnda  24      size hdr(ps);           $ pointer to hash header
      19
      20      access q1vars;          $ access global q1 variables.
      21      access nscod;           $ access variables global to cod.
      22
      23
      24      get_heap(hl_ht + ebsz + hl_htb, getht);  $ get heap block
      25
      26      htype(getht)     = h_ht;
      27      hlink(getht)     = 0;
      28      neb(getht)       = 0;
      29      lognhedrs(getht) = 0;
      30
      31      tmp = getht + hl_ht;  $ point to template
      32      hdr = tmp   + ebsz;  $ single hash header
      33
      34      htype(tmp)     = ebtp;
      35      hlink(tmp)     = 0;
      36      is_ebhedr(tmp) = yes; $ set template
      37      is_ebtemp(tmp) = yes;
      38      eblink(tmp)    = hdr;
      39      ebsize(tmp)    = ebsz;
      40
      41      htype(hdr)     = h_htb;
      42      hlink(hdr)     = 0;
      43      is_ebhedr(hdr) = yes;  $ set hash header
      44      is_ebtemp(hdr) = no;
      45      eblink(hdr)    = tmp;
      46
      47
      48      end fnct getht;
       1 .=member packinfo
       2      subr packinfo(bits, vals, key_val, key_addr, fm);
       3
       4$ this routine finds out various information about a packed object
       5$ from its form.
       6
       7      size bits(ps),      $ set to ptbits or ls_bits of object
       8           vals(ps),      $ set to ptvals of object
       9           key_val(hs),   $ key for packed ints
      10           key_addr(ps),  $ address of key for packed elements
      11           fm(ps);        $ form of object
      12
      13      size ptyp(ps),      $ type of packed value
      14           base(ps),         $ type of base
      15           mx(ps);           $ maximim packed value
      16
      17      access q1vars;          $ access global q1 variables.
      18      access nscod;           $ access variables global to cod.
      19
      20
      21      if ft_type(fm) = f_ptuple then
      22          ptyp = ft_elmt(fm);
      23      else
      24          ptyp = ft_im(fm);
      25      end if;
      26
      27      if ft_type(ptyp) = f_sint then
      28          build_spec(key_val, t_int, 0);
      29          key_addr = 0;
      30
      31          mx = ft_lim(ptyp);
      32          bits = .fb. mx;
      33
      34      else  $ element of constant base
      35          base = ft_base(ptyp);
      36
      37          key_val  = 0;
      38          key_addr = ft_samp(base) - 1;
      39
      40          mx   = ft_lim(base);
      41          bits = .fb. mx;
      42      end if;
      43
      44      vals = hs / bits;
      45
      46      return;
      47
      48      end subr packinfo;
       1 .=member incnst
       2      subr incnst(nam);
       3
       4$ this routine initializes the run time value of a constant 'nam'.
       5$ the symbol table entry for the constant has already been
       6$ initialized to the proper omega; we call various library
       7$ routines to build the run time value.
       8
       9$ constant sets, tuples, and bases are built in the dynamic part
      10$ of the heap, while strings, ints, and reals are built in the
      11$ static area.
      12
      13$ when constants are first built by the semantic pass they are
      14$ given very basic types such as 'set(*)'. named constants can
      15$ be given more detailed types through the repr statement.
      16
      17$ when the semantic pass processes the repr for a constant, it
      18$ does not do a complete check to see that the repr is consistent
      19$ with the value; instead it does a 1 level check. this means that
      20$ whenver we build a composite object we must check whether its
      21$ elements have been built with the desired type and call the
      22$ libraries convert routine if not.
      23
      24$ note that 'convert' always returns omega if it is unsuccessful.
      25
      26
      27      size nam(ps);           $ symbol to be processed
      28
      29      size fm(ps);            $ its form
      30      size addr(ps);          $ its address
      31      size vp(ps);            $ val pointer
      32      size vl(ps);            $ val length
      33
      34      size j(ps);             $ loop index
      35      size s(ps);             $ pointer to set
      36      size len(ps);           $ length of string
      37      size str(sds_sz);       $ value of string
      38      size ss(ssz);           $ string specifier
      39      size p(ps), p1(ps);     $ heap pointers
      40      size nam1(ps);          $ symbol table pointer for element
      41      size xfm(ps);           $ element type
      42      size elmt(hs);          $ specifier for element
      43      size comp(hs);          $ specifier for tuple component
      44      size spec(hs);          $ specifier
      45      size dom(hs);           $ domain element
      46      size im(hs);            $ image
      47      size im1(hs);           $ old image
      48      size v(ws);             $ word of val entry
      49      size tup(hs);           $ tuple specifier
      50      size bform(ps);         $ form of base
      51      size base(ps);          $ pointer to base
      52      size f1(ps);            $ form of base element
      53      size f2(ps);            $ form of case map domain element
      54      size j1(ps), j2(ps);    $ loop indices
      55      size card(ps);          $ number of elements in set/map
      56      size n(ps);             $ number of dereference/locate operations
      57
      58      size tstart(ps);        $ value of 't' at start of routine
      59
      60      size nulllc(ssz);       $ allocates null string
      61      size nulltup(hs);       $ allocates null tuple
      62      size fval(hs);          $ retrieves map image
      63      size rset2(hs);         $ builds set of two elements
      64      size withs(hs);         $ adds element to set
      65      size setform(hs);       $ forms n-elenemt set of form fm
      66      size tupform(hs);       $ forms n-elenemt tuple of form fm
      67      size convert(hs);       $ general conversion utility
      68      size err_val(hs);       $ error value utility
      69
      70      access q1vars;          $ access global q1 variables.
      71      access nscod;           $ access variables global to cod.
      72
      73
      74      tstart = t;
      75
      76      fm   = form(nam);
      77      addr = address(nam);
      78
      79      vp = vptr(nam);
      80      vl = vlen(nam);
      81
      82      is_om(addr) = no; $ clear is_om
      83
      84      go to case(ft_type(fm)) in f_min to f_max;
      85
      86/case(f_gen)/  $ general
      87
      88      call abort('reached bad label in incnst');
      89
      90/case(f_sint)/
      91
      92      value(addr) = val(vp);
      93      return;
      94
      95/case(f_sstring)/       $ short string
      96
      97$ unpack val entry into sds string 'str'
      98      str = 0;
      99
     100      do j = 0 to vl-1;
     101          .f. 1 + j*ws, ws, str = val(vp+j);
     102      end do;
asca  19 .+ascebc if (ascebc_flag) call ascsds(str);  $ convert to ascii
     103
     104$ repack into setl short character string
     105      sc_nchars_ heap(addr) = .len. str;
     106
     107      do j = 1 to .len. str;
stra  75          scchar(heap(addr), j) = .ch. j, str;
     109      end do;
     110
     111      return;
     112
     113/case(f_atom)/     $ atom
     114
     115      $ the only constants of type 'f_atom' are 'true' and 'false'.
     116      value(addr) = val(vp);
     117      return;
     118
     119/case(f_latom)/   $ long atom
     120
     121      $ there should be no constant of this type.
     122      go to fail;
     123
     124/case(f_elmt)/
     125
     126$ get a pointer to the base and convert the element to the right type,
     127$ then do a locate.
     128
     129      bform = ft_base(form(nam));  $ form of base
     130      base  = value(ft_samp(bform));  $ pointer to base
     131
     132$ get element and convert to proper type if necessary.
     133
     134      nam1 = val(vp);   $ symtab pointer for element
     135      if (nam1 = sym_om) go to fail;
     136
     137      elmt = heap(address(nam1));
     138
     139      if ^ can_assign(ft_elmt(bform), form(nam1)) then
     140          elmt = convert(elmt, ft_elmt(bform));
     141          if (is_om_ elmt) go to fail;
     142      end if;
     143
     144      call locate(p, elmt, base, yes);
     145
     146      value(addr) = p;
     147
     148      return;
     149
     150/case(f_int)/     $ long int
     151
     152$ try to build a short integer. if this is impossible, build a
     153$ 1 word long int.
     154
     155      v = val(vp);
     156
mjsa  12      put_intval(v, spec);
mjsa  13      heap(addr) = spec;
     172      return;
     173
     174/case(f_string)/     $ indirect string
     175
     176$ unpack val entry into sds string 'str'
     177      str = 0;
     178
     179      do j = 0 to vl-1;
     180          .f. 1 + j*ws, ws, str = val(vp+j);
     181      end do;
asca  20 .+ascebc if (ascebc_flag) call ascsds(str);  $ convert to ascii
     182
     183$ repack into setl long string
     184      len = .len. str;
stra  76
stra  77      if len <= sc_max then  $ allocate short string
stra  78          if len = 0 then  $ allocate null string
stra  79              build_spec(spec, t_string, 0);
stra  80          else
stra  81              spec = spec_char;  $ one-character template
stra  82              scchar(spec, 1) = .ch. 1, str;  $ copy character
stra  83          end if;
stra  84          heap(addr) = spec;
stra  85          return;
stra  86      end if;
stra  87
     185      ss  = nulllc(len);
     186
     187      ss_len(ss) = len;
     188
     189      do j = 1 to len;
     190          icchar(ss, j) = .ch. j, str;
     191      end do;
     192
     193      value(addr) = ss;
     194      return;
     195
     196/case(f_real)/   $ real
     197
     198      get_const(real_nw, p);
     199      htype(p) = h_real;
     200
     201      rval(p) = val(vp);
     202
     203      value(addr) = p;
     204      return;
     205
     206/case(f_uint)/   $ untyped int and real
     207
     208/case(f_ureal)/
     209
     210      heap(addr) = val(vp);
     211      return;
     212
     213/case(f_tuple)/   $ tuples
     214
     215/case(f_ptuple)/
     216
     217/case(f_mtuple)/
     218
     219/case(f_rtuple)/
     220
     221/case(f_ituple)/
     222
     223$ push the values of the components, then call the tuple former.
     224
     225$ there is one unusual context in which we build constant pairs:
     226$ as elements of the maps used for case statements. in this case
     227$ the labels do not recieve symbol table entries, and so we must
     228$ look directly in symtab for their values.
     229
     230      do j = 0 to vl-1;
     231          nam1 = val(vp+j);   $ symtab pointer to component
     232
     233          if ft_type(fm) = f_mtuple then
     234              xfm = mttab(ft_elmt(fm)+1+j);
     235          else
     236              xfm = ft_elmt(fm);
     237          end if;
     238
     239          if nam1 = sym_om then
     240              comp = heap(ft_samp(xfm));
     241              push1(comp);
     242
     243          elseif symtype(nam1) = f_lab then
     244              build_spec(comp, t_lab, labval(nam1));
     245              push1(comp);
     246
     247          else
     248              comp = heap(address(nam1));
     249
     250              if ^ can_assign(xfm, form(nam1)) then
     251                  if is_om_ comp then
     252                      comp = heap(ft_samp(xfm));
     253
     254                  elseif xfm = f_ureal & form(nam1) = f_real then
     255                      comp = rval(value_ comp);
     256
     257                  elseif xfm = f_uint & is_fint(form(nam1)) then
     258                      get_intval(comp, comp);
     259
     260                  else
     261                      comp = convert(comp, xfm);
     262                      if (is_om_ comp) go to fail;
     263                  end if;
     264              end if;
     265
     266              push1(comp);
     267
     268              if is_funt(xfm) then  $ push skip word
     269                  build_spec(spec, t_skip, 2);
     270                  push1(spec);
     271              end if;
     272          end if;
     273
     274      end do;
     275
     276      heap(addr)      = tupform(fm, vl);
     277      is_shared(addr) = yes;
     278
     279      if (is_om(addr)) go to fail;
     280
     281      return;
     282
     283/case(f_uset)/       $ standard set
     284
     285/case(f_lset)/       $ local subset
     286
     287/case(f_rset)/       $ remote subset
     288
     289/case(f_umap)/       $ standard map
     290
     291/case(f_lmap)/       $ local map
     292
     293/case(f_rmap)/       $ remote map
     294
     295/case(f_lpmap)/      $ local packed map
     296
     297/case(f_limap)/      $ local integer map
     298
     299/case(f_lrmap)/      $ local real map
     300
     301/case(f_rpmap)/      $ remote packed map
     302
     303/case(f_rimap)/      $ remote integer map
     304
     305/case(f_rrmap)/      $ remote real map
     306
     307      xfm = ft_elmt(fm);
     308
     309      if is_fplex(fm) & is_fmap(fm) then  $ local map(_ plex base)
     310          do j = 0 to vl-1;
     311              nam1 = val(vp+j);
     312              elmt = heap(address(nam1));
     313
     314              if form(nam1) ^= xfm then
     315                  elmt = convert(elmt, xfm);
     316              end if;
     317
     318              if (is_om_ elmt) go to fail;
     319
     320              dom = tcomp(value_ elmt, 1);
     321              im  = tcomp(value_ elmt, 2);
     322
     323              im1 = fval(value(addr), value_ dom, no);
     324
     325              if is_om_ im1 then
     326                  im1 = im;
     327              elseif is_multi_ im1 then
     328                  im1 = withs(im1, im, yes);
     329                  is_multi_ im1 = yes;
     330              else
     331                  im1 = rset2(im, im1);
     332                  is_multi_ im1 = yes;
     333              end if;
     334
     335              call sfval(value(addr), value_ dom, im1);
     336          end do;
     337
     338      elseif is_fplex(fm) then  $ local set(_ plex base)
     339          do j = 0 to vl-1;
     340              nam1 = val(vp+j);
     341              if (form(nam1) ^= xfm) go to fail;
     342
     343              elmt = heap(address(nam1));
     344              call sfval(value(addr), value_ elmt, yes);
     345          end do;
     346
     347      else   $ any other set
     348
     349          card = 0;
     350
     351          do j = 0 to vl-1;
     352              nam1 = val(vp+j);   $ symtab pointer to element
     353
     354              if nam1 = sym_om then
     355                  go to fail;
     356
     357              else
     358                  elmt = heap(address(nam1));  $ value of element
     359
     360                  if is_casemap(nam) & is_fbsd(form(nam)) then
     361
     362                      f1 = ft_dom(fm);              $ map domain form
     363                      f2 = form(val(vptr(nam1)));   $ domain value form
     364                      n  = 0;
     365
     366                      while ft_type(f1) = f_elmt & f1 ^= f2;
     367                          if (ft_type(ft_base(f1)) = f_pbase) quit;
     368                          f1 = ft_elmt(ft_base(f1));   n = n + 1;
     369                      end while;
     370
     371                      dom = tcomp(value_ elmt, 1);  $ q2 domain element
     372
     373                      if ^ can_assign(f1, f2) then
     374                          dom = convert(dom, f1);
     375
     376                          if is_om_ dom then
     377                              call codwrn(02, val(vptr(nam1)));
     378                              cont do j;
     379                          end if;
     380                      end if;
     381
     382                      do j1 = n to 1 by -1;
     383                          $ check whether map domain is in proper base
     384                          f1 = ft_dom(fm);
     385                          do j2 = 2 to j1;
     386                              f1 = ft_elmt(ft_base(f1));
     387                          end do;
     388                          f2   = ft_base(f1);          $ form of base
     389                          base = value(ft_samp(f2));   $ pointer to base
     390                          call locate(p, dom, base, no);
     391
     392                          if ^ loc_found & ft_lim(f2) > 0 then
     393                              call codwrn(03, val(vptr(nam1)));
     394                              cont do j;
     395                          end if;
     396
     397                          build_spec(dom, t_elmt, p);
     398                      end do;
     399                  end if;
     400
     401                  if ^ can_assign(xfm, form(nam1)) then
     402                      elmt = convert(elmt, xfm);
     403                  end if;
     404
     405                  if is_om_ elmt then
     406                      if is_casemap(nam) then
     407                          call codwrn(04, val(vptr(nam1)));
     408                          cont do j;
     409                      else
     410                          go to fail;
     411                      end if;
     412                  end if;
     413              end if;
     414
     415              push1(elmt);   card = card + 1;
     416          end do;
     417
     418          heap(addr)      = setform(fm, card);
     419          is_shared(addr) = yes;
     420
     421          if is_om(addr) then
     422              if is_casemap(nam) then
     423                  call ermsg(26, 0);
     424                  tstart = t;
     425                  return;
     426              else
     427                  go to fail;
     428              end if;
     429          end if;
     430      end if;
     431
     432      return;
     433
     434/case(f_base)/       $ base
     435
     436$ building a constant base involves two things:
     437
     438$ 1. locating all the elements in the base
     439
     440$ 2. building a tuple containing the elements of the base in their
     441$    order of insertion. the symbol table entry immediately after
     442$    the entry for the base is set to contain a specifier for this
     443$    tuple.
     444
     445$    note that the symbol table entry for the tuple now contains the
     446$    head of a list of heap words which must be set to the specifier
     447$    for the tuple.
     448
     449$ we begin by allocating the tuple then do steps (1) and (2) together.
     450
     451      tup = nulltup(f_tuple, vl);
     452
     453$ fill in all the heap words which refer to the tuple.
     454      p = address(nam) - 1;    $ first word to be filled in
     455
     456      while p ^= 0;
     457          p1      = heap(p);    $ next word to be filled in
     458
     459          heap(p) = tup;
     460          p       = p1;
     461      end while;
     462
     463      p1       = value_ tup;
     464      nelt(p1) = vl;
     465
     466      s = value(address(nam));  $ pointer to base
     467
     468      do j = 0 to vl-1;
     469          nam1 = val(vp+j);
     470          elmt = heap(address(nam1));
     471
     472          call locate(p, elmt, s, yes);
     473
     474          build_spec(comp, t_elmt, p);
     475          tcomp(p1, ebindx(p)) = comp;
     476      end do;
     477
     478      return;
     479
     480
     481/case(f_pbase)/   $ plex  base
     482
     483/case(f_proc)/   $ procedure
     484
     485/case(f_memb)/  $ member
     486
     487/case(f_lab)/  $ labels
     488
     489/case(f_error)/
     490
     491/case(f_uimap)/
     492
     493/case(f_urmap)/
     494
     495      return;
     496
     497/fail/    $ illegal repr for constant
     498
     499      call ermsg(10, nam);
     500
     501      t = tstart;
     502
     503      return;
     504
     505      end subr incnst;
       1 .=member initio
       2      subr initio;
       3
       4$ this routine initializes various sets and maps used by the
       5$ run time i/o routines. these maps are:
       6
       7$ fid:    sends file names into file numbers. its initial
       8$         value is null.
       9
      10$ free:   set of free file numbers. initially null.
      11
      12$ fmax:   maximum file number allocated so far. initially 5.
      13
      14$ fmodes: maps file modes into io_xxx codes.
      15
      16
      17      size str(hs),  $ specifier for string
      18           int(hs),  $ specifier for int
      19           tup(hs);  $ specifier for tuple
      20      size i(ps);             $ loop index
      21
      22      size bldstr(hs),  $ builds string from sds
      23           tupform(hs),  $ tuple former
      24           setform(hs),  $ set former
      25           nullset(hs);  $ builds null set
      26
      27      access q1vars;          $ access global q1 variables.
      28      access nscod;           $ access variables global to cod.
      29
      30      +*  fmodes_max = 13 **
      31      size  fmodes_str(.sds. 12); dims fmodes_str(fmodes_max);
      32      size  fmodes_typ(ps);  dims fmodes_typ(fmodes_max);
      33
      34 .=zzyorg z
      35
      36      +* s(str,typ)  =        $ initialize map table
      37          data fmodes_str(zzyz) = str;
      38          data fmodes_typ(zzyz) = typ;
      39          **
      40
      41      s('print',        io_print)
      42      s('coded',        io_get)
      43      s('binary',       io_read)
      44      s('coded-in',     io_get)
      45      s('coded-out',    io_put)
      46      s('binary-in',    io_read)
      47      s('binary-out',   io_write)
      48      s('text',         io_get)
      49      s('text-in',      io_get)
      50      s('text-out',     io_put)
      51      s('foreign',      io_read)
      52      s('foreign-in',   io_read)
      53      s('foreign-out',  io_write)
      54      macdrop(s)
      55
      56      $ build 'fid'
      57      heap(s_fid) = nullset(f_umap, 0);
      58
      59
      60$ build free
      61      heap(s_free) = nullset(f_uset, 0);
      62
      63$ build fmax. note that the following file numbers are
      64$ reserved
      65
      66$ 1:    standard input file
      67$ 2:    standard output file
      68$ 3:    q2 file
      69$       nb. this file is used as an "private" file by the library.
      70$       for example, file id 3 is used to write the dynamic storage
      71$       dump.
      72$
      73      build_spec(heap(s_fmax), t_int, 3)
      74
      75
      76 .-mc.
      77$ build fmode
      78      do i = 1 to fmodes_max;
      79          str = bldstr(fmodes_str(i));
      80          build_spec(int, t_int, fmodes_typ(i));
      81          push2(str,int);
      82          tup = tupform(f_tuple, 2);
      83          push1(tup);
      84      end do;
      85
      86      heap(s_fmode) = setform(f_umap, fmodes_max);
      87 .+mc.
      88 $ here to build map for full lower and full upper case
      89  size cases(hs);
      90      do i = 1 to fmodes_max;
      91        size cstr(.sds. 12);
      92        cstr = fmodes_str(i);
      93        do cases = 1 to 2;
      94            if cases=1 then call stpc(cstr); $ primary case
      95            else call stsc(cstr); end if;
asca  21 .+ascebc   if (ascebc_flag) call ascsds(cstr);  $ convert to ascii
      96            str = bldstr(cstr);
      97            build_spec(int, t_int, fmodes_typ(i));
      98            push2(str,int);
      99            tup = tupform(f_tuple, 2);
     100            push1(tup);
     101         end do;
     102      end do;
     103
     104      heap(s_fmode) = setform(f_umap, 2*(fmodes_max));
     105 ..mc
     106
     107      end subr initio;
       1 .=member inidbg
       2      subr inidbg;
       3$
       4$ this routine initialises various tables used  by  the  debugging  and
       5$ trace package.
       6$
       7      size p(ps);             $ pointer to tuple
       8      size opc(ps);           $ q2 opcode
       9      size j1(ps);            $ loop indices
      10      size j2(ps);
      11      size j3(ps);
      12
      13      size nulltup(hs);       $ allocates null tuple
      14
      15      access q1vars;          $ access global q1 variables.
      16      access nscod;           $ access variables global to cod.
      17
      18
      19$ we start by initialising s_ovar,  the packed tuple which flags opcodes
      20$ with o-variables, i.e. the is_ovar predicate.
      21$
      22$ note that the second argument to nulltup  is the expected nelt of  the
      23$ tuple;   nulltup adds a breathing space of 1/3 to this before it allo-
      24$ cates the tuple.   since this tuple will never grow,  we counter  this
      25$ otherwise wasted allocation by  requesting less space than we actually
      26$ need.
      27$
      28$ also note that we rely here on the fact that  the components of packed
      29$ tuples are initialised to omega, i.e. zero.
      30
      31      heap(s_ovar) = nulltup(f_pt11, (2*q2_maximum+2)/3);
      32      p = value(s_ovar);
      33
      34      nelt(p) = q2_maximum;
      35
      36      do j1 = q1_minimum to q1_maximum;
      37          if ( ^ ops_ovar(j1)) cont;
      38
      39          opc = std_op(j1); if (opc ^= 0) pt11comp(p, opc) = 1;
      40
      41          do j2 = f_min to f_max;
      42              opc = spec_op(j1, j2); if (opc = 0) cont do j2;
      43              pt11comp(p, opc) = 1;
      44          end do;
      45      end do;
      46
      47      do j1 = q1_of to q1_sofa;
      48          do j2 = f_umap to f_rpmap;
      49              do j3 = ft_min to ft_max;
      50                  opc = of_op(j1, j2, j3); if (opc = 0) cont do j3;
      51                  pt11comp(p, opc) = 1;
      52              end do;
      53          end do;
      54      end do;
      55
      56      do j1 = q2_of to q2_ofarmm;
      57          opc = share_op(j1); if (opc = 0) cont do j1;
      58          pt11comp(p, opc) = 1;
      59      end do;
      60
      61      pt11comp(p, q2_inci) = 1;
      62      pt11comp(p, q2_newat2) = 1;
      63      pt11comp(p, q2_set1) = 1;   pt11comp(p, q2_set2) = 1;
      64      pt11comp(p, q2_tup1) = 1;   pt11comp(p, q2_tup2) = 1;
      65
      66
      67      end subr inidbg;
       1 .=member bintype
       2      fnct bin_type(opc, form1, form2);
       3
       4$ this routine determines the result type for +, -, *, and mod.
       5$ f1 and f2 are the forms of the inputs.
       6
       7      size opc(ps),           $ q1 opcode
       8           form1(ps),         $ input forms
       9           form2(ps);
      10
      11      size bin_type(ps);      $ form of result
      12
      13      size f1(ps),            $ dereferenced input forms
      14           f2(ps);
      15
      16      access q1vars;          $ access global q1 variables.
      17      access nscod;           $ access variables global to cod.
      18
      19
      20      f1 = deref_typ(form1);
      21      f2 = deref_typ(form2);
      22
      23      if opc = q1_slash then  $ real or untyped real
      24          if is_funt(f1) & is_funt(f2) then
      25              bin_type = f_ureal;
      26          else
      27              bin_type = f_real;
      28          end if;
      29
      30      elseif opc = q1_div then  $ int or untyped int
      31          if is_funt(f1) & is_funt(f2) then
      32              bin_type = f_uint;
      33          else
      34              bin_type = f_int;
      35          end if;
smfb 336      elseif is_fint(f1) & is_fint(f2) then
smfb 337          if is_funt(f1) & is_funt(f2) then
smfb 338              bin_type = f_uint;
smfb 339          else
smfb 340              bin_type = f_int;
smfb 341          end if;
smfb 342
smfb 343      elseif is_freal(f1) & is_freal(f2) then
smfb 344          if is_funt(f1) & is_funt(f2) then
smfb 345              bin_type = f_ureal;
smfb 346          else
smfb 347              bin_type = f_real;
smfb 348          end if;
smfb 349
smfb 350      elseif is_fstr(f1) & is_fstr(f2) then
smfb 351          bin_type = f_string;
smfb 352
      36
      37      elseif f1 = f2 then
      38$
      39$ in general, a binary operation on two objects of type 'f1' will
      40$ yield a result of type 'f1'.  there are three exceptions:
      41$
      42$ 1. since the difference of two short ints may be a long int,
      43$    we set bin_type = f_int.
      44$
      45$ 2. the union of two smaps may be a map or smap.  since we dont
      46$    know which we set the result to f_gen.
      47$
      48$ 3. the addition of two known-length tuples will be a known-length
      49$    tuple, but of different length.  since we do not have a specific
      50$    form for the result available, we return f_tuple.
      51$
      52          if opc = q1_sub & ft_type(f1) = f_sint then
      53              bin_type = f_int;
      54          elseif opc = q1_add & ft_mapc(f1) = ft_smap then
      55              bin_type = f_gen;
      56          elseif opc = q1_add & is_ftup(f1) & ft_lim(f1) ^= 0 then
      57              bin_type = f_tuple;
      58          else
      59              bin_type = f1;
      60          end if;
      61
      71      elseif is_ftup(f1) & is_ftup(f2) then
      72          bin_type = f_tuple;
      73
      74      elseif is_fset(f1) & is_fset(f2) then
      75          bin_type = f_uset;
      76
      77      elseif opc = q1_mult then  $ look for string * int
      78
      79          if is_fstr(f1) & is_fint(f2) then
      80              bin_type = f_string;
      81          elseif is_fint(f1) & is_fstr(f2) then
      82              bin_type = f_string;
      83          elseif is_ftup(f1) & is_fint(f2) then $ look for tuple * int
      84              bin_type = f_tuple;
      85
      86          elseif is_fint(f1) & is_ftup(f2) then $ look for int * tuple
      87              bin_type = f_tuple;
      88
      89          else
      90              bin_type = f_gen;
      91          end if;
      92
      93      else  $ error
      94          bin_type = f_gen;
      95      end if;
      96
      97
      98      end fnct bin_type;
       1 .=member dereftyp
       1 .=member elmttype
       2      fnct elmt_type(f);
       3
       4$ this routine returns the element type of a form
       5
       6      size f(ps);  $ form of set, etc
       7
       8      size elmt_type(ps); $ result
       9
      10      access q1vars;          $ access global q1 variables.
      11      access nscod;           $ access variables global to cod.
      12
      13
      14      if ft_type(f) = f_mtuple then
      15          elmt_type = f_gen;
      16
      17      elseif is_fset(f) ! is_ftup(f) then
      18          elmt_type = ft_elmt(f);
      19
      20      elseif is_fstr(f) then
      21          elmt_type = f_string;
      22
      23      else
      24          elmt_type = f_gen;
      25      end if;
      26
      27
      28      end fnct elmt_type;
       1 .=member domtype
       2      fnct dom_type(f);
       3
       4$ this routine returns the domain type of a form. for the moment
       5$ we consider tuples to be maps on integers.
       6
       7      size f(ps); $ form of set, etc
       8
       9      size dom_type(ps); $ result
      10
      11      access q1vars;          $ access global q1 variables.
      12      access nscod;           $ access variables global to cod.
      13
      14
      15      if is_fset(f) then
      16          dom_type = ft_dom(f);
      17
      18      elseif is_ftup(f) ! is_fstr(f) then
      19          dom_type = f_sint;
      20
      21      else
      22          dom_type = f_gen;
      23      end if;
      24
      25
      26      end fnct dom_type;
       1 .=member imtype
       2      fnct im_type(f);
       3
       4$ this routine determines the image type of an object, i.e. the
       5$ type returned if we apply f(x) to it.
       6
       7      size f(ps);
       8
       9      size im_type(ps);
      10
      11      access q1vars;          $ access global q1 variables.
      12      access nscod;           $ access variables global to cod.
      13
      14
      15      if is_fset(f) then
      16          im_type = ft_im(f);
      17          if (ft_mapc(f) = ft_mmap) im_type = elmt_type(im_type);
      18
      19      elseif ft_type(f) = f_mtuple then
      20          im_type = f_gen;
      21
      22      elseif is_ftup(f) then
      23          im_type = ft_elmt(f);
      24
      25      elseif is_fstr(f) then
      26          im_type = f_string;
      27
      28      else
      29          im_type = f_gen;
      30      end if;
      31
      32
      33      end fnct im_type;
       1 .=member cntype
       2      fnct cn_type(fm, i);
       3
       4$ this routine returns the type of the i-th component of a tuple
       5
       6      size fm(ps),    $ form of tuple
       7           i(ps);     $ number of component
       8
       9      size cn_type(ps);  $ form returned
      10
      11      access q1vars;          $ access global q1 variables.
      12      access nscod;           $ access variables global to cod.
      13
      14
      15      if ft_type(fm) = f_mtuple then
      16          if i = 0 ! i > ft_lim(fm) then
      17              cn_type = f_gen;
      18          else
      19              cn_type = mttab(ft_elmt(fm) + i);
      20          end if;
      21
      22      else
      23          cn_type = ft_elmt(fm);
      24      end if;
      25
      26
      27      end fnct cn_type;
       1 .=member compntyp
       2      fnct compn_typ(fm, x);
       3
       4$ this routine determines the result type of an 'of' operation
       5$ y := f(x). its arguments are:
       6
       7$ fm:     the type of f.
       8$ x:      symtab pointer to x.
       9
      10$ it is similar to im_type except that it catches the case where
      11$ f is a mixed tuple and x is an integer constant.
      12
      13      size fm(ps),  $ form of f
      14           x(ps); $ symtab pointer to x
      15
      16      size compn_typ(ps);     $ form returned
      17
      18      size v(ps);      $ value of index
      19
      20      access q1vars;          $ access global q1 variables.
      21      access nscod;           $ access variables global to cod.
      22
      23
      24      if ft_type(fm) = f_mtuple then
      25          if is_const(x) & is_fint(form(x)) then
      26              v = symval(x);
      27              if v <= ft_lim(fm) then
      28                  compn_typ = mttab(ft_elmt(fm) + v);
      29              else
      30                  compn_typ = f_gen;
      31              end if;
      32          else
      33              compn_typ = f_gen;
      34          end if;
      35
      36      elseif is_fstr(fm) then
      37          compn_typ = f_string;
      38
      39      elseif is_ftup(fm) then
      40          compn_typ = ft_elmt(fm);
      41
      42      elseif is_fmap(fm) then
      43          if ft_mapc(fm) = ft_mmap then
      44              compn_typ = ft_elmt(ft_im(fm));
      45          else
      46              compn_typ = ft_im(fm);
      47          end if;
      48
      49      else
      50          compn_typ = f_gen;
      51      end if;
      52
      53
      54      end fnct compn_typ;
       1 .=member rsettype
       2      fnct rset_type(f);
       3
       4$ this routine determines the range set type of an object, i.e.
       5$ the mode returned by applying f<> to it.
       6
       7      size f(ps);
       8
       9      size rset_type(ps);
      10
      11      access q1vars;          $ access global q1 variables.
      12      access nscod;           $ access variables global to cod.
      13
      14
      15      if is_fset(f) then
      16          if ft_mapc(f) = ft_mmap then
      17              rset_type = ft_im(f);
smfc  37          elseif ft_mapc(f) = ft_map then
smfc  38              rset_type = ft_imset(f);
      18          else
      19              rset_type = f_uset;
      20          end if;
      21
      22      else
      23          rset_type = f_gen;
      24      end if;
      25
      26
      27      end fnct rset_type;
       1 .=member argtype
       2      fnct arg_type(rout, n);
       3
       4$ this routine returns the type of a procedure argument. its arguments
       5$ are:
       6
       7      size rout(ps),  $ symtab pointer to routine
       8           n(ps);     $ argument number
       9
      10      size nn(ps),    $ copy of n.
      11           vp(ps),    $ vptr for procedure
      12           vary(1),   $ true of procedure has variable number of args
      13           na(1);     $ number of arguments
      14
      15      size arg_type(ps);  $ type returned
      16
      17      size fm(ps);  $ type of routine
      18
      19      access q1vars;          $ access global q1 variables.
      20      access nscod;           $ access variables global to cod.
      21
      22
      23      fm = form(rout);
      24
      25      if fm = f_proc then
      26          arg_type = f_gen;
      27
      28      else
      29          vp   = vptr(rout);   $ look for variable number of arguments
      30          vary = val(vp+1);
      31          na   = val(vp+2);
      32
      33          nn = n;
      34          if (vary & nn > na) nn = na;
      35
      36          arg_type = mttab(ft_elmt(fm)+nn);
      37      end if;
      38
      39
      40      end fnct arg_type;
       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      access q1vars;          $ access global q1 variables.
      26      access nscod;           $ access variables global to cod.
      27
      28$ we begin by jumping on the error number to assign the proper string
      29$ to 'string'. we use the following convenience macro:
      30
      31      +*  er(n, str) =
      32          /case(n)/   string = str;  go to esac;
      33          **
      34
      35
suna  50      +*  max_case  =  30  **
      37      if ( ^ (1 <= n & n <= max_case)) n = 0;
      38      go to case(n) in 0 to max_case;
      39
      40      er(00, 'valid error text')
      41      er(01, 'valid target for conversion to string');
      42      er(02, 'valid types for newat')
      43      er(03, 'valid types for conversion')
      44      er(04, 'to have proper number of arguments');
      45      er(05, 'valid left hand side for -x := nl-');
      46      er(06, 'valid left hand side for -x := nult-');
      47      er(07, 'valid target for conversion to integer');
      48      er(08, 'valid target for conversion to real');
      49      er(09, 'no conversions to label or procedure');
      50      er(10, 'constant to have desired type');
      51      er(11, 'valid use of object based on plex base');
      52      er(12, 'to be typed when using full run time error checking');
      53      er(13, '-back- control card option');
      54      er(14, 'setl binary tuple header')
      55      er(15, 'setl binary tuple trailer')
      56      er(16, 'setl binary integer')
      57      er(17, 'setl binary real')
      58      er(18, 'setl binary boolean')
      59      er(19, 'valid setl binary boolean value')
      60      er(20, 'setl binary string')
      61      er(21, 'to be assigned only within its defined range')
      62      er(22, 'to have a set mode')
      63      er(23, 'a main program - code file cannot be executed')
      64      er(24, 'valid source for conversion to string')
      65      er(25, 'valid source for conversion to atom')
      66      er(26, 'a valid case map (are all case tag values unique ?)')
suna  51      er(27, ':  internal compiler error (symtype(lab) ^= lab)')
suna  52      er(28, ':  internal compiler error (opcode(i1) ^= lab/tag)')
suna  53      er(29, ':  internal compiler error (i2 = 0)')
suna  54      er(30, ':  internal compiler error (opcode(i2) ^= lab/tag)')
      67
      68/esac/   $ print error message
      69
      70      put, skip;              $ emit blank line, position next line
      71      call contlpr(27, yes);  $ start to echo to the terminal
      72 .+s10    put, '?';           $ emit s10 error message marker
      73 .+s20    put, '?';           $ emit s20 error message marker
      74      put ,'*** error ' :n ,i;
      75      if (curmemb ^= 0) put ,' at ' :symsds(curmemb) ,a;
      76      if (currout ^= 0) put ,'.'    :symsds(currout) ,a;
      77      if (curmemb ^= 0) put ,'.'    :stmt_count      ,i;
suna  55      if n < 27 ! 30 < n then  put ,':  expect ';  end if;
      79      if (nam ^= 0) put :symsds(nam) ,a ,x(1);
      80      put: string, a, ' ***', skip;
      81
      82      call contlpr(27, no);   $ stop to echo to the terminal
      83
      84      if et_flag then  $ error trace desired
      85          put, 'q1 address: ': now, il, skip;
      86
      87          if codep ^= 0 then
      88              put, skip, 'last q2 instruction: ', skip;
      89              call dinst(codep);
      90          end if;
      91      end if;
      92
      93      if unit_type = unit_proc then   $ procedure scope
      94          $ nb. if an error message is printed during fixup, etc., then
      95          $ we should not insert this quadruple since we have not yet
      96          $ started the code block.  the result is an ill-formated heap.
      97          call em2(q2_error, 0, 0, 0);
      98      end if;
      99
     100      error_count = error_count + 1;
     101
     102      if error_count > cel then
     103          call contlpr(27, yes);
     104          put, '*** code generator error limit exceeded ***', skip;
     105          call contlpr(27, no);
     106
     107          call codtrm(yes);
     108
     109      elseif 14 <= n & n <= 20 then
     110          call abort('permanent i/o error in setl q1 interface');
suna  56
suna  57      elseif 27 <= n & n <= 30 then
suna  58          call codtrm(yes);   $ abnormal termination
     111      end if;
     112
     113      macdrop(max_case)
     114
     115
     116      end subr ermsg;
       1 .=member codwrn
       2      subr codwrn(n, nam);
       3$
       4$ this routine is similar to ermsg, except that it prints warnings.
       5$
       6$ warnings have the form:
       7$
       8$ *** warning xxx at line yyy - zzz ***
       9$
      10$ where:
      11$
      12$ xxx is the warning number
      13$ yyy is the current line number
      14$ nam is a symbol table pointer
      15$ zzz is the individual message
      16$
      17$ if 'nam' is non-zero, we print the name of the symbol table entry.
      18$
      19      size n(ps);             $ message number
      20      size nam(ps);           $ optional symtab pointer
      21
      22      size string(sds_sz);    $ string for message
      23
      24      access q1vars;          $ access global q1 variables.
      25      access nscod;           $ access variables global to cod.
      26$
      27$ we begin by jumping on the error number to assign the proper string
      28$ to 'string'.  we use the following convenience macro:
      29$
      30      +* wa(n, str) =
      31          /case(n)/   string = str;   go to esac;
      32          **
      33
      34
      35      +*  max_case  =  04  **
      36      if ( ^ (1 <= n & n <= max_case)) n = 0;
      37      go to case(n) in 0 to max_case;
      38
      39      wa(00, 'valid warning text')
      40      wa(01, 'is an unsatisfied external procedure')
      41      wa(02, 'is an unreachable case tag')
      42      wa(03, 'is an unreachable case tag')
      43      wa(04, 'is an unreachable case tag')
      44
      45/esac/   $ print warning
      46
      47      put ,skip;
      48      call contlpr(27, yes);  $ start to echo to the terminal
      49 .+s10    put ,':';           $ emit standard s10 warning character
      50 .+s20    put ,':';           $ emit standard s20 warning character
      51      put ,'*** warning ' :n ,i;
      52      if (curmemb ^= 0) put ,' at ' :symsds(curmemb) ,a;
      53      if (currout ^= 0) put ,'.'    :symsds(currout) ,a;
      54      if (curmemb ^= 0) put ,'.'    :stmt_count      ,i;
      55      put ,': ';
      56      if (nam ^= 0) put :symsds(nam) ,a ,x(1);
      57      put :string ,a ,' ***' ,skip;
      58      call contlpr(27, no);   $ stop to echo to the terminal
      59
      60
      61
      62      end subr codwrn;
       1 .=member sdump
       2
       3
       4 .+tr notrace entry;
       5
       6
       7      subr sdump;
       8
       9$ this routine dumps symtab and various related tables.
      10
      11
      12      call symdump;   $ dump symtab
      13      call valdump;   $ dump val
      14      call fmdump;  $ dump formtab
      15      call mtdump;  $ dump mttab
      16
      17
      18      end subr sdump;
       1 .=member symdump
       2      subr symdump;
       3
       4$ this routine dumps symtab. the dump is formatted in columns,
       5$ with a series of column headings printed at standard intervals.
       6
       7
       8      size j(ps),   $ loop index
       9           str(sds_sz),  $ symbol name as sds
      10           lines(ps);  $ number of lines since last heading
      11
      12      access q1vars;          $ access global q1 variables.
      13      access nscod;           $ access variables global to cod.
      14
      15
      16      put, skip(2), column(7), 's y m t a b     d u m p     -     ':
      17           symsds(curunit), a, skip(2);
      18
      19      lines = lines_max;   $ set to force new heading
      20
      21      do j = 1 to symtabp;
      22          lines = lines + 1;
      23
      24          if lines > lines_max then  $ print heading
      25              put, skip(2), column(7),
      26                   'index  name         vptr   vlen   alias  form   ',
      27                   'addr   labval altrep rp tm sk rd wr pm st ld re ',
      28                   'mb sn al bk',
      29                   skip, column(7),
      30                   '------------------------------------------------',
      31                   '------------------------------------------------',
      32                   '-----------',
      33                   skip(2);
      34
      35              lines = 1;
      36          end if;
      37
      38          str = symsds(j);
      39          if (.len. str > 10) .len. str = 10;
      40
      41          put, column(007): j,             i,
      42               column(014): str,           a,
      43               column(027): vptr(j),       i,
      44               column(034): vlen(j),       i,
      45               column(041): alias(j),      i,
      46               column(048): form(j),       i,
      47               column(055): address(j),    i,
      48               column(062): labval(j),     i,
      49               column(069): altrep(j),     i,
      50               column(076): is_repr(j),    i,
      51               column(079): is_temp(j),    i,
      52               column(082): is_stk(j),     i,
      53               column(085): is_read(j),    i,
      54               column(088): is_write(j),   i,
      55               column(091): is_param(j),   i,
      56               column(094): is_store(j),   i,
      57               column(097): is_ldef(j),    i,
      58               column(100): is_rec(j),     i,
      59               column(103): is_memb(j),    i,
      60               column(106): is_seen(j),    i,
      61               column(109): is_alias(j),   i,
      62               column(112): is_back(j),    i,
      63               skip;
      64      end do;
      65
      66
      67      end subr symdump;
       1 .=member valdump
       2      subr valdump;
       3
       4$ this routine dumps 'val'. we dump val in byte format, three
       5$ entries per line. the first column contains the first third of
       6$ val, the second column the next third, etc.
       7
       8
       9      size rows(ps),  $ number of rows in dump
      10           tab(ps),  $ current tab position
      11           i(ps),  $ index over rows
      12           j(ps), $ index over columns
      13           indx(ps);  $ index over val
      14
      15      access q1vars;          $ access global q1 variables.
      16      access nscod;           $ access variables global to cod.
      17
      18
      19      put, skip(2), column(7), 'v a l     d u m p     -     ':
      20           symsds(curunit), a, skip(2);
      21
      22      rows = (valp-1)/3 + 1;  $ number of rows
      23
      24      do i = 1 to rows;
      25          do j = 1 to 3;
      26              indx = (j-1) * rows + i;
      27              tab = 7 + (j-1) * 35;
      28
      29              put, column(tab): indx, i, '.',
      30                   column(tab+7): val(indx), bl;
      31          end do;
      32
      33          put, skip;
      34      end do;
      35
      36      put, skip(2);
      37
      38
      39      end subr valdump;
       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      access q1vars;          $ access global q1 variables.
      63      access nscod;           $ access variables global to cod.
      64
      65
      66      put ,skip(4)
      67          ,'f o r m t a b    d u m p   -   '
      68          :symsds(curunit) ,a
      69          ,skip(2);
      70
      71
      72      lines = lines_max;      $ set to force new heading
      73
      74      do fm = 0 to formtabp;
      75
      76          lines = lines + 1;
      77
      78          if lines > lines_max then  $ print heading
      79              put ,skip(2)
      80                      ,'index type    mapc elmt  dom   im    imset '
      81                      ,'base  deref low   lim   hsh nlt samp'
      82                  ,skip
      83                      ,'-------------------------------------------'
      84                      ,'-------------------------------------'
      85                  ,skip;
      86
      87              lines = 1;
      88          end if;
      89
      90          put ,column(01) :fm                  ,i
      91              ,column(07) :ftname(ft_type(fm)) ,a;
      92
      93          if (is_fmap(fm)) put ,column(15) :mname(ft_mapc(fm)) ,a;
      94
      95          put ,column(20) :ft_elmt(fm)  ,i
      96              ,column(26) :ft_dom(fm)   ,i
      97              ,column(32) :ft_im(fm)    ,i
      98              ,column(38) :ft_imset(fm) ,i
      99              ,column(44) :ft_base(fm)  ,i
     100              ,column(50) :ft_deref(fm) ,i;
     101
     102          put ,column(56);
     103          if (ft_type(fm) = f_sint)        put :ft_low(fm)    ,i;
     104          if (is_floc(fm) ! is_fbase(fm))  put :ft_bit(fm)    ,i;
     105
     106          put ,column(62);
     107          if (ft_type(fm) = f_sint)        put :ft_lim(fm)    ,i;
     108          if (ft_type(fm) = f_proc)        put :ft_lim(fm)    ,i;
     109          if (is_ftup(fm) ! is_fbase(fm))  put :ft_lim(fm)    ,i;
     110          if (is_floc(fm))                 put :ft_pos(fm)    ,i;
     111          if (is_frem(fm) & is_fmap(fm))   put :ft_tup(fm)    ,i;
     112
     113          put ,column(68);
     114          if (is_ftup(fm) ! is_fset(fm))   put :ft_hashok(fm) ,i;
     115
     116          put ,column(72);
     117          if (is_ftup(fm) ! is_fset(fm))   put :ft_neltok(fm) ,i;
     118
     119          put ,column(76) :ft_samp(fm)  ,i;
     120
     121          if is_fbase(fm) then
     122              put ,column(86);
     123              do j1 = f_lset to f_lpmap; if ( ^ is_floc(j1)) cont do j1;
     124                  put :ft_num(fm, j1) ,i(5);
     125              end do;
     126          end if;
     127
     128          put ,skip;
     129      end do;
     130
     131
     132      end subr fmdump;
       1 .=member mtdump
       2      subr mtdump;
       3
       4$ this routine dumps 'mttab'. we dump mttab in byte format, three
       5$ entries per line. the first column contains the first third of
       6$ mttab, the second column the next third, etc.
       7
       8
       9      size lines(ps);         $ number of lines since last heading
      10      size j1(ps), j2(ps);    $ loop indices
      11
      12      access q1vars;          $ access global q1 variables.
      13      access nscod;           $ access variables global to cod.
      14
      15
      16      put, skip(2), column(7), 'm t t a b     d u m p     -     ':
      17           symsds(curunit), a, skip(2);
      18
      19      lines = lines_max;      $ set to force new heading
      20
      21      do j1 = 0 to (mttabp+9)/10;
      22          lines = lines + 1;
      23          if lines > lines_max then
      24              put ,skip(2)
      25                      ,'index      ...0   ...1   ...2   ...3   ...4'
      26                      ,'   ...5   ...6   ...7   ...8   ...9'
      27                  ,skip
      28                      ,'-------------------------------------------'
      29                      ,'-----------------------------------'
      30                  ,skip;
      31               lines = 1;
      32          end if;
      33
      34          put :j1 ,i(5) ,'.   ';
      35
      36          do j2 = 0 to 9; if (j1*10+j2 > mttabp) quit do j1;
      37              if j1*10+j2 = 0 then put ,x(7); cont do j2; end if;
      38              put :mttab(j1*10+j2) ,i(6) ,x;
      39          end do;
      40
      41          put ,skip;
      42
      43      end do;
      44
      45      put ,skip(2);
      46
      47
      48      end subr mtdump;
       1 .=member formfm
       2      fnct format_form(frm);
       3
       4$ this function formats a form table entry into a human-readable string.
       5
       6      size frm(ps);           $ form table pointer
       7
       8      size format_form(hs);   $ specifier for result string
       9
      10      size fm(ps);            $ parameter to recursive part of function
      11      size j(ps);             $ loop index
      12      size new(ps);           $ junk pointer to get extra heap word
      13      size len(ps);           $ current length of str
      14      size ss1(ssz);          $ string specifier
      15      size p(ps);             $ pointer to long string data block
      16      size ptr1(ps);          $ pointer to current word
      17      size ofs1(ps);          $ offset in current word
      18      size c(chsiz);          $ character code to be written
      19      size int1(ws);          $ integer
      20      size int2(ws);          $ integer
      21      size int3(ws);          $ integer
      22      size str1(sds_sz);      $ sds to be written
      23      size ret_sds(ps);       $ return address for write_sds subroutine
      24      size ret_int(ps);       $ return address for write_int subroutine
      25
      26
      27 .=zzyorg  b                  $ reset counter for stack offsets
      28      size tstart(ps);        $ initial recursion stack pointer
      29      local(retpt);           $ return pointer
      30      local(f1);              $ form table pointer
      31      local(j1);              $ loop index
      32      local(n1);              $ loop limit
      33
      34      size nulllc(ssz);       $ allocates null string
      35      size var_id(sds_sz);    $ returns symbol table name as sds
      36
      37      access q1vars;          $ access global q1 variables.
      38      access nscod;           $ access variables global to cod.
      39
      40
      41      ss1 = nulllc(1);
      42      p = ss_ptr(ss1); ptr1 = p + hl_lchars; ofs1 = chorg; len = 0;
      43
      44
      45 .=zzyorg a                   $ reset counter for return label
      46      fm = frm;               $ copy parameter
      47      tstart = t;             $ save recusion stack pointer
      48
      49/entry/                       $ recursive entry pointer
      50      r_entry;                $ increament recursion stack
      51
      52      go to case(ft_type(fm)) in f_gen to f_lab;
      53
      54
      55/case(f_gen)/                 $ general
      56
      57      str1 = 'general'; l_call(write_sds);
      58      go to exit;
      59
      60
      61/case(f_sint)/                $ short integer
      62
      63      str1 = 'integer '; l_call(write_sds);
      64      int1 = ft_low(fm); l_call(write_int);
      65      str1 = '..'; l_call(write_sds);
      66      if ft_lim(fm) = 0 then int1 = maxsi; else int1 = ft_lim(fm); end;
      67      l_call(write_int);
      68      go to exit;
      69
      70
      71/case(f_sstring)/             $ short character string
      72
      73/case(f_string)/              $ long character string
      74
      75      str1 = 'string'; l_call(write_sds);
      76      go to exit;
      77
      78
      79/case(f_atom)/                $ short atom
      80
      81/case(f_latom)/               $ long atom
      82
      83      str1 = 'atom'; l_call(write_sds);
      84      go to exit;
      85
      86
      87/case(f_elmt)/                $ element-of-base
      88
      89      str1 = 'elmt '; l_call(write_sds);
      90      str1 = var_id(ft_samp(ft_base(fm)), 0); l_call(write_sds);
      91      go to exit;
      92
      93
      94/case(f_uint)/                $ untyped integer
      95
      96      str1 = 'untyped integer'; l_call(write_sds);
      97      go to exit;
      98
      99
     100/case(f_ureal)/               $ untyped real
     101
     102      str1 = 'untyped real'; l_call(write_sds);
     103      go to exit;
     104
     105
     106/case(f_int)/                 $ long or short integer
     107
     108      str1 = 'integer'; l_call(write_sds);
     109      go to exit;
     110
     111
     112/case(f_real)/                $ real
     113
     114      str1 = 'real'; l_call(write_sds);
     115      go to exit;
     116
     117
     118/case(f_ptuple)/              $ packed tuple
     119
     120      str1 = 'packed '; l_call(write_sds);
     121
     122
     123/case(f_ituple)/              $ tuple(untyped integer)
     124
     125/case(f_rtuple)/              $ tuple(untyped real)
     126
     127/case(f_tuple)/               $ standard tuple
     128
     129      str1 = 'tuple('; l_call(write_sds);
     130      f1 = fm; fm = ft_elmt(f1);
     131      r_call;
     132      if ft_lim(f1) ^= 0 then
     133          str1 = ')('; l_call(write_sds);
     134          int1 = ft_lim(f1); l_call(write_int);
     135      end if;
     136      c = 1r); l_call(write_char);
     137      go to exit;
     138
     139
     140/case(f_mtuple)/              $ mixed tuple
     141
     142      str1 = 'tuple('; l_call(write_sds);
     143      f1 = fm; n1 = ft_lim(fm); j1 = 1;
     144      while j1 <= n1;
     145          fm = mttab(ft_elmt(f1)+j1);
     146          r_call;
     147          if j1 < n1 then str1 = ', '; l_call(write_sds); end if;
     148          j1 = j1 + 1;
     149      end while;
     150      c = 1r); l_call(write_char);
     151      go to exit;
     152
     153
     154/case(f_uset)/                $ standard set
     155
     156      f1 = fm; fm = ft_elmt(fm);
     157      if ft_type(fm) = f_elmt then
     158          str1 = 'sparse set(';
     159      else
     160          str1 = 'set(';
     161      end if;
     162      l_call(write_sds);
     163      r_call;
     164      c = 1r); l_call(write_char);
     165      go to exit;
     166
     167
     168/case(f_lset)/                $ local subset
     169
     170      str1 = 'local set('; l_call(write_sds);
     171      f1 = fm; fm = ft_elmt(fm);
     172      r_call;
     173      c = 1r); l_call(write_char);
     174      go to exit;
     175
     176
     177/case(f_rset)/                $ remote subset
     178
     179      str1 = 'remote set('; l_call(write_sds);
     180      f1 = fm; fm = ft_elmt(fm);
     181      r_call;
     182      c = 1r); l_call(write_char);
     183      go to exit;
     184
     185
     186/case(f_umap)/                $ standard map
     187
     188      f1 = fm; fm = ft_dom(fm);
     189      if ft_type(fm) = f_elmt then
     190          str1 = 'sparse '; l_call(write_sds);
     191      end if;
     192      if      ft_mapc(f1) = ft_map  then str1 = 'map(';
     193      elseif  ft_mapc(f1) = ft_smap then str1 = 'smap(';
     194      elseif  ft_mapc(f1) = ft_mmap then str1 = 'mmap<';
     195      else                               assert 0;
     196      end if;
     197      l_call(write_sds);
     198      r_call;
     199      if ft_mapc(f1) = ft_mmap then str1 = '! '; else str1 = ') '; end;
     200      l_call(write_sds);
     201      fm = ft_im(f1);
     202      r_call;
     203      go to exit;
     204
     205
     206/case(f_lpmap)/               $ local packed map
     207
     208      str1 = 'packed '; l_call(write_sds);
     209
     210
     211/case(f_limap)/               $ local integer map
     212
     213/case(f_lrmap)/               $ local real map
     214
     215/case(f_lmap)/                $ local map
     216
     217      str1 = 'local '; l_call(write_sds);
     218      if      ft_mapc(fm) = ft_map  then str1 = 'map(';
     219      elseif  ft_mapc(fm) = ft_smap then str1 = 'smap(';
     220      elseif  ft_mapc(fm) = ft_mmap then str1 = 'mmap<';
     221      else                               assert 0;
     222      end if;
     223      l_call(write_sds);
     224      f1 = fm; fm = ft_dom(f1);
     225      r_call;
     226      if ft_mapc(f1) = ft_mmap then str1 = '! '; else str1 = ') '; end;
     227      l_call(write_sds);
     228      fm = ft_im(f1);
     229      r_call;
     230      go to exit;
     231
     232
     233/case(f_rpmap)/               $ remote packed map
     234
     235      str1 = 'packed '; l_call(write_sds);
     236
     237
     238/case(f_rimap)/               $ remote integer map
     239
     240/case(f_rrmap)/               $ remote real map
     241
     242/case(f_rmap)/                $ remote map
     243
     244      str1 = 'remote '; l_call(write_sds);
     245      if      ft_mapc(fm) = ft_map  then str1 = 'map(';
     246      elseif  ft_mapc(fm) = ft_smap then str1 = 'smap(';
     247      elseif  ft_mapc(fm) = ft_mmap then str1 = 'mmap<';
     248      else                               assert 0;
     249      end if;
     250      l_call(write_sds);
     251      f1 = fm; fm = ft_dom(f1);
     252      r_call;
     253      if ft_mapc(f1) = ft_mmap then str1 = '! '; else str1 = ') '; end;
     254      l_call(write_sds);
     255      fm = ft_im(f1);
     256      r_call;
     257      go to exit;
     258
     259
     260/case(f_base)/                $ base
     261
     262      f1 = fm; fm = ft_elmt(f1);
     263      str1 = 'base('; l_call(write_sds);
     264      r_call;
     265      c = 1r); l_call(write_char);
     266      go to exit;
     267
     268
     269/case(f_pbase)/               $ plex base
     270
     271      str1 = 'plex base'; l_call(write_sds);
     272      go to exit;
     273
     274
     275/case(f_uimap)/               $ unbased untyped integer map
     276
     277/case(f_urmap)/               $ unbased untyped real map
     278
     279      str1 = '(illegal form)'; l_call(write_sds);
     280      go to exit;
     281
     282
     283/case(f_error)/               $ error
     284
     285      str1 = 'error'; l_call(write_sds);
     286      go to exit;
     287
     288
     289/case(f_proc)/                $ procedure or operator
     290
     291      f1 = fm; n1 = ft_lim(fm);
     292      if n1 = 0 then
     293          str1 = 'procedure'; l_call(write_sds);
     294      else
     295          str1 = 'procedure('; l_call(write_sds);
     296          j1 = 1;
     297          while 1;
     298              fm = mttab(ft_elmt(f1)+j1);
     299              r_call;
     300              if (j1 = n1) quit while;
     301              if j1 < n1-1 then str1 = ', '; else str1 = ') '; end if;
     302              l_call(write_sds);
     303              j1 = j1 + 1;
     304          end while;
     305      end if;
     306      go to exit;
     307
     308
     309/case(f_memb)/                $ member
     310
     311      str1 = 'member'; l_call(write_sds);
     312      go to exit;
     313
     314
     315/case(f_lab)/                 $ label
     316
     317      str1 = 'label'; l_call(write_sds);
     318      go to exit;
     319
     320
     321/exit/                        $ recursive exit point
     322
     323      r_exit;                 $ pop recursion stack
     324
     325      if t ^= tstart then     $ return to previous invocation
     326          go to rlab(retpt) in 1 to zzya;
     327      end if;
     328
     329      ss_len(ss1) = len;
     330      build_spec(format_form, t_istring, ss1);
     331      return;
     332
     333
     334/write_sds/                   $ local subroutine to write sds
     335
     336      ret_sds = retpt;
     337      do j = 1 to .len. str1;
     338          c = .ch. j, str1; l_call(write_char);
     339      end do;
     340
     341      go to rlab(ret_sds) in 1 to zzya;
     342
     343
     344/write_int/                   $ local subroutine to write unsigned int
     345
     346      ret_int = retpt;
     347
     348      if int1 = 0 then
     349          c = 1r0; l_call(write_char);
     350      else
     351          int2 = int1 / 10; int3 = 1;
     352          while int2 > 0;
     353               int2 = int2 / 10; int3 = int3 * 10;
     354          end while;
     355          while int3 > 0;
     356               c = charofdig(int1 / int3); l_call(write_char);
     357               int1 = int1 - (int1 / int3) * int3; int3 = int3 / 10;
     358          end while;
     359      end if;
     360
     361      go to rlab(ret_int) in 1 to zzya;
     362
     363
     364/write_char/                  $ local subroutine to write single char
     365
     366      .f. ofs1, chsiz, heap(ptr1) = c; len = len + 1;
     367      if ofs1 = chlst then
     368          assert p + lc_nwords(p) = h;
     369          assert lcalloc(len) = lc_nwords(p);
     370          get_heap(1, ptr1); ofs1 = chorg;
     371          lc_nwords(p) = lc_nwords(p) + 1;
     372      else
     373          ofs1 = ofs1 + chinc;
     374      end if;
     375
     376      go to rlab(retpt) in 1 to zzya;
     377
     378
     379      end fnct format_form;
       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
       9      size j(ps),   $ loop index
      10           str(sds_sz);   $ routine name as sds
      11
      12      access q1vars;          $ access global q1 variables.
      13      access nscod;           $ access variables global to cod.
      14
      15
      16      put, skip(2), column(7), 'c o d e     d u m p    -     ':
      17           symsds(curunit), a, skip(2);
      18
      19      do j = 1 to blocktabp;
      20
      21          put, skip(2),  $ print heading
      22               column(07), 'block: ':   j,   i,
      23               column(25), 'first: ':   b_first(j), i,
      24               skip;
      25
      26          call dblock(b_first(j));  $ print instructions
      27      end do;
      28
      29
      30      end subr q1dump;
       1 .=member q2dump
       2      subr q2dump;
       3
       4$ this routine dumps the current code block.
       5
       6      size p1(ps);  $ pointer to instruction
       7
       8      access q1vars;          $ access global q1 variables.
       9      access nscod;           $ access variables global to cod.
      10
      11      put, skip, column(7), 'code for ': symsds(curunit), a,
      12           ' address = ': labval(curunit), i, skip(2);
      13
      14      p1 = code_org + hl_code;
      15
      16      while p1 < code_org + codenw(code_org);
      17          call dinst(p1);
      18          p1 = p1 + inst_nw;
      19      end while;
      20
      21
      22      end subr q2dump;
       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           opc(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_exp)         =  'exp':
      25           opname(q1_eq)          =  'eq':
      26           opname(q1_ge)          =  'ge':
      27           opname(q1_lt)          =  'lt':
smfb 353           opname(q1_pos)         =  'pos':
      28           opname(q1_in)          =  'in':
      29           opname(q1_incs)        =  'incs':
      30           opname(q1_less)        =  'less':
      31           opname(q1_lessf)       =  'lessf':
      32           opname(q1_max)         =  'max':
      33           opname(q1_min)         =  'min':
      34           opname(q1_mod)         =  'mod':
      35           opname(q1_atan2)       =  'atan2':
      36           opname(q1_mult)        =  'mult':
      37           opname(q1_ne)          =  'ne':
      38           opname(q1_notin)       =  'notin':
      39           opname(q1_npow)        =  'npow':
      40           opname(q1_slash)       =  'slash':
      41           opname(q1_sub)         =  'sub':
      42           opname(q1_with)        =  'with':
      43           opname(q1_not)         =  'not':
      44           opname(q1_even)        =  'even':
      45           opname(q1_odd)         =  'odd':
      46           opname(q1_isint)       =  'is_int':
      47           opname(q1_isreal)      =  'is_real':
      48           opname(q1_isstr)       =  'is_str':
      49           opname(q1_isbool)      =  'is_bool':
      50           opname(q1_isatom)      =  'is_atom':
      51           opname(q1_istup)       =  'is_tuple':
      52           opname(q1_isset)       =  'is_set':
      53           opname(q1_ismap)       =  'is_map':
      54           opname(q1_arb)         =  'arb':
      55           opname(q1_dom)         =  'dom':
      56           opname(q1_range)       =  'range':
      57           opname(q1_pow)         =  'pow':
      58           opname(q1_nelt)        =  'nelt':
      59           opname(q1_abs)         =  'abs':
      60           opname(q1_char)        =  'char':
      61           opname(q1_ceil)        =  'ceil':
      62           opname(q1_floor)       =  'floor':
      63           opname(q1_fix)         =  'fix':
      64           opname(q1_float)       =  'float':
      65           opname(q1_sin)         =  'sin':
      66           opname(q1_cos)         =  'cos':
      67           opname(q1_tan)         =  'tan':
      68           opname(q1_arcsin)      =  'arcsin':
      69           opname(q1_arccos)      =  'arccos':
      70           opname(q1_arctan)      =  'arctan':
      71           opname(q1_tanh)        =  'tanh':
      72           opname(q1_expf)        =  'expf':
      73           opname(q1_log)         =  'log':
      74           opname(q1_sqrt)        =  'sqrt':
      75           opname(q1_rand)        =  'rand':
      76           opname(q1_sign)        =  'sign':
      77           opname(q1_type)        =  'type':
      78           opname(q1_str)         =  'str':
      79           opname(q1_val)         =  'val':
      80           opname(q1_end)         =  'end':
      81           opname(q1_subst)       =  'subst':
      82           opname(q1_newat)       =  'newat':
      83           opname(q1_time)        =  'time':
      84           opname(q1_date)        =  'date':
      85           opname(q1_na)          =  'na':
      86           opname(q1_set)         =  'set':
      87           opname(q1_set1)        =  'set1':
      88           opname(q1_tup)         =  'tup':
      89           opname(q1_tup1)        =  'tup1':
      90           opname(q1_from)        =  'from':
      91           opname(q1_fromb)       =  'fromb':
      92           opname(q1_frome)       =  'frome':
      93           opname(q1_next)        =  'next':
      94           opname(q1_nextd)       =  'nextd':
      95           opname(q1_inext)       =  'inext':
      96           opname(q1_inextd)      =  'inextd':
      97           opname(q1_of)          =  'of':
      98           opname(q1_ofa)         =  'ofa':
      99           opname(q1_argin)       =  'argin':
     100           opname(q1_argout)      =  'argout':
     101           opname(q1_asn)         =  'asn':
     102           opname(q1_push)        =  'push':
     103           opname(q1_free)        =  'free':
     104           opname(q1_sof)         =  'sof':
     105           opname(q1_sofa)        =  'sofa':
     106           opname(q1_send)        =  'send':
     107           opname(q1_ssubst)      =  'ssubst':
     108           opname(q1_call)        =  'call':
     109           opname(q1_goto)        =  'goto':
     110           opname(q1_if)          =  'if':
     111           opname(q1_ifnot)       =  'ifnot':
smfb 354           opname(q1_bif)         =  'bif':
smfb 355           opname(q1_bifnot)      =  'bifnot':
smfb 356           opname(q1_ifasrt)      =  'ifasrt':
     112           opname(q1_case)        =  'case':
     113           opname(q1_stop)        =  'stop':
     114           opname(q1_entry)       =  'entry':
     115           opname(q1_exit)        =  'exit':
smfb 357           opname(q1_ok)          =  'ok':
smfb 358           opname(q1_lev)         =  'lev':
smfb 359           opname(q1_fail)        =  'fail':
smfb 360           opname(q1_succeed)     =  'succeed':
     120           opname(q1_asrt)        =  'asrt':
     121           opname(q1_stmt)        =  'stmt':
     122           opname(q1_label)       =  'label':
smfb 361           opname(q1_tag)         = 'tag':
     124           opname(q1_debug)       =  'debug':
     125           opname(q1_trace)       =  'trace':
     126           opname(q1_notrace)     =  'notrace':
     127           opname(q1_error)       =  'error':
     128           opname(q1_noop)        =  'noop':
     129           opname(q1_ifeq)        =  'ifeq':
     130           opname(q1_ifge)        =  'ifge':
     131           opname(q1_iflt)        =  'iflt':
     132           opname(q1_ifin)        =  'ifin':
     133           opname(q1_ifnin)       =  'ifnin':
     134           opname(q1_ifinc)       =  'ifincs':
     135           opname(q1_ifsub)       =  'ifsubs':
     136           opname(q1_ifne)        =  'ifne';
     137
     138      access q1vars;          $ access global q1 variables.
     139      access nscod;           $ access variables global to cod.
     140
     141
     142
     143      p = first;
     144      lines = lines_max;
     145
     146      while p ^= 0;
     147          lines = lines + 1;
     148
     149          if lines > lines_max then
     150              lines = 1;
     151
     152              put, skip(2), column(7),
     153                   'index   opcode              args',
     154                   skip, column(7),
     155                   '-----   ------              ----',
     156                   skip;
     157          end if;
     158
     159          opc = opcode(p);
     160
     161          put, column(07):           p, i,
     162               column(15): opname(opc), a;
     163
     164          tab = 15;
     165
     166          do j = 1 to nargs(p);  $ print arguments
     167              tab = tab + 15;
     168
     169              if tab > 60 then
     170                  put, skip;
     171                  tab = 30;
     172              end if;
     173
     174              if opc = q1_stmt then
     175                  put, column(tab): argn(p, j), i;
     176
     177              else
     178                  str = symsds(argn(p, j));
     179                  if (.len. str > 14) .len. str = 14;
     180
     181                  put, column(tab): str, a;
     182              end if;
     183
     184          end do;
     185
     186          put, skip;
     187          p = next(p);
     188      end while;
     189
     190
     191      end subr dblock;
       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           namesds(sds_sz); $ gets string from names ptr
      12
      13      size n(ps),    $ integer to be converted
      14           j(ps);  $ loop index
      15
      16      access q1vars;          $ access global q1 variables.
      17      access nscod;           $ access variables global to cod.
      18
      19      if p = 0 then
      20          symsds = '';
      21
      22      elseif is_internal(p) then
      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
      32      else
      33          symsds = namesds(name(p));
      34      end if;
      35
      36
      37      end fnct symsds;
       1 .=member namesds
       2      fnct namesds(nam);
       3
       4$ this routine converts a names entry to an sds string.
       5
       6      size nam(ps);  $ pointer to names entry
       7
       8      size namesds(sds_sz);
       9
      10      size j(ps),  $ loop index
      11           words(ps);  $ number of words in names entry
      12
      13      access q1vars;          $ access global q1 variables.
      14      access nscod;           $ access variables global to cod.
      15
      16
      17      if (nam = 0) go to error;
      18
      19      words = n_sorg(nam)/ws;
      20      if (words = 0) go to error;
      21
      22      do j = 0 to words-1;
      23          .f. 1+j*ws, ws, namesds = names(nam+j);
      24      end do;
      25
      26      return;
      27
      28/error/
      29
      30      namesds = '';
      31
      32
      33      end fnct namesds;
       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      size msg(.sds. 50);  $ message string
       8
       9      access q1vars;          $ access global q1 variables.
      10      access nscod;           $ access variables global to cod.
      11
      12
      13      put ,skip;              $ emit blank line
      14      call contlpr(27, yes);  $ start to echo to the terminal
      15      put, '*** compiler table overflow - ': msg, a, ' ***', skip;
      16      call contlpr(27, no);   $ stop to echo to the terminal
      17
      18      error_count = error_count + 1;
      19      call codtrm(yes);       $ abnormal termination
      20
      21      end subr overfl;
       1 .=member abort
       2      subr abort(msg);
       3
       4 $ prints error message and terminates execution
       5
       6      size msg(.sds. 50);
       7
       8      access q1vars;          $ access global q1 variables.
       9      access nscod;           $ access variables global to cod.
      10
      11
      12      put ,skip;              $ emit blank line
      13      call contlpr(27, yes);  $ start to echo to the terminal
      14      put, '*** ': msg, a, ' ***', skip;
      15      call contlpr(27, no);   $ stop to echo to the terminal
      16
      17      error_count = error_count + 1;
      18      call codtrm(yes);       $ abnormal termination
      19
      20
      21      end subr abort;
       1 .=member codtrm
       2      subr codtrm(abort);
       3
       4$ this routine terminates execution of the code generator.  the flag
       5$ 'abort' indicates whether normal or abnormal termination is in place.
       6
       7
       8      size abort(1);          $ flags abnormal termination
       9
      10      access q1vars;          $ access global q1 variables.
      11      access nscod;           $ access variables global to cod.
      12
      13
sunb  44      if lcs_flag then  $ print statistics
sunb  45          put ,skip;  $ emit blank line
      15
sunb  46          if error_count = 0 then
sunb  47              put, 'no errors were detected.', skip;
sunb  48          else
sunb  49              put, 'number of errors detected = ': error_count, i, skip;
sunb  50          end if;
sunb  51      end if;
      21
      22      if abort then
sunb  52          if (lcs_flag) put ,skip ,'abnormal termination.' ,skip;
      24
      25          if et_flag then
      26              call sdump;
      27              call q1dump;
      28              call dumpds1;
      29          end if;
      30          call ltlfin(1,0);
      31      end if;
      32
      33$ otherwise finish the environnment and write out q2.
      34
      35      call inienv3;           $ finish initialisation of environment
      36
      37      err_mode = rem;         $ copy error mode into environment block
      38
      39      write q2_file, q2_checkw, current_q2;
      40      call wrheap1(q2_file);  $ write the environment block
      41
      42      +* put_slice(file, table, first, last)  =
      43          write file, first, last;
      44          if (first <= last) write file, table(first) to table(last);
      45          **
      46
      47      put_slice(q2_file,       heap,       snam_org,    snam_end)
      48      put_slice(q2_file,       heap,        sym_org,     sym_end)
      49      put_slice(q2_file,       heap,         ca_org,     h_const)
smfb 362      put_slice(q2_file,        heap,  ca_org+ca_lim,    h_names1)
smfb 363      put_slice(q2_file,        heap,       h_names2,         h-1)
      51      put_slice(q2_file,       heap,          savet,       h_lim)
      52      put_slice(q2_file,  a_formtab,              1,  formtabp+1)
      53      put_slice(q2_file,      mttab,              1,      mttabp)
      54
      55      macdrop(put_slice);
      56
      57
      58
sunb  53    if lcs_flag then  $ print q2 statistics
      59      put ,skip ,'q2 statistics:'
      60          ,skip ,'min symtab size = '    :sym_end-sym_org+1 ,i ,'. '
      61                ,'min constants area = ' :h_const-ca_org    ,i ,'. '
      62                ,'min dynamic heap = '   :h-ca_org-ca_lim   ,i ,'. '
      63          ,skip ,'q2 code size = '       :code_tot          ,i ,'. '
      64                ,'initial heap size = '  :h-ca_org          ,i ,'. '
smfa 200                ,'min heap size = '      :2*(sym_end-sym_org+1)
      66                                       +  h_const-ca_org
smfb 364                                       + h_names1-ca_org-ca_lim+1
smfb 365                                       + h-h_names2        ,i ,'. '
      68          ,skip ,'exec statements = '    :stmt_tot          ,i ,'. '
      69                ,'q2 instructions = '    :code_tot/inst_nw  ,i ,'. '
      70                ,'q2 format date = '     :current_q2        ,i ,'. '
      71          ,skip;
      72
      73      put ,skip ,'normal termination.' ,skip;
sunb  54    end if;
      74
      75      if .len. sq1_title then
      76          file sq1_file   access = release;
      77      else
      78          file q1_file    access = release;
      79      end if;
      80
      81      file q2_file access = release;
      82
      83      call ltlterm(3, 0);
      84
      85
      86      end subr codtrm;
       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      access q1vars;          $ access global q1 variables.
       8      access nscod;           $ access variables global to cod.
       9
      10      put, skip(2), column(7),
      11          '*** fatal error detected by system at line ':
      12          stmt_count, i, skip(2);
      13
      14      if (^ et_flag) return;  $ trace not requested
      15
      16      call sdump;             $ dump symtab
      17      call q1dump;            $ dump q1
      18
      19
      20      end subr usratp;
       1 .=member grbcol
       2
       3$ this deck contains routines for a dummy garbage collector.
       4
       5      subr grbcol;
       6
       7
       8      call abort('insufficient main storage');
       9
      10
      11      end subr grbcol;
      12
      13      +*  d(rout)  =  $ dummy routine
      14          subr rout;
      15          end subr rout;
      16          **
      17
      18      d(grbmrk)
      19      d(grbadj)
      20      d(grbcmp)
      21      d(gbcmp)
      22      d(gbcmpc)
      23      d(gbcmp1)
      24      d(gbcmp2)
      25      d(gbcmp3)
      26      d(gbcmp4)
      27      d(gbcmp5)
      28      d(grbtrm)
      29      d(envrsi)
      30      d(blksz)
      31      d(dumpds1)
      32      d(checkptr)
      33      d(snap)

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

Powered by Plone CMS, the Open Source Content Management System

This site conforms to the following standards: