Personal tools
You are here: Home Projects SETL SETL Source code LIB: Runtime library.
Document Actions

LIB: Runtime library.

by Paul McJones last modified 2021-03-19 21:56

LIB: Runtime library. stllib.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$                ll          iiiiiiiiii  bbbbbbbbb
      15$                ll          iiiiiiiiii  bbbbbbbbbb
      16$                ll              ii      bb      bb
      17$                ll              ii      bb      bb
      18$                ll              ii      bbbbbbbbb
      19$                ll              ii      bbbbbbbbb
      20$                ll              ii      bb      bb
      21$                ll              ii      bb      bb
      22$                llllllllll  iiiiiiiiii  bbbbbbbbbb
      23$                llllllllll  iiiiiiiiii  bbbbbbbbb
      24$
      25$
      26$       t h e    s e t l    r u n    t i m e    l i b r a r y
      27$
      28$                         p a r t    o n e
      29$
      30$
      31$
      32$       this software is part of the setl programming system
      33$                address queries and comments to
      34$
      35$                          setl project
      36$                 department of computer science
      37$                      new york university
      38$           courant institute of mathematical sciences
      39$                       251 mercer street
      40$                      new york, ny  10012
      41$
       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 the dotted line below, and change the macro
      19$ 'prog_level' to the current julian date.
      20
      21$ ......................................................................
smff   1
smff   2
smff   3$ 01/07/85     85007     s. freudenberger
smff   4$
smff   5$  1. correct the domain check for acos and asin.
smff   6$     module affected:  relf.
smff   7$  2. correct the carry computation in valli.
smff   8$     module affected:  valli.
strb   1
strb   2
strb   3$ 07/24/84     84206     s. freudenberger
strb   4$
strb   5$  1. fix several small bugs of correction set stra.
strb   6$     modules affected: intrp2, printa, reada, putr, getr, subst,
strb   7$                       substs, and ssubst.
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: interp, intrp2, intrp3, eqprim, eqstr, add,
stra   7$                       addstr, mult, multstr, member, of, sof, next,
stra   8$                       inext, inextd, print2, readstr, putb1, getb1,
stra   9$                       getf1, putf1, bldsds, bldstr, gethash, getnelt,
stra  10$                       subst, substs, ssubst, ssubsts, lt, valli, sabs,
stra  11$                       schar, break, span, match, lpad, len, any,
stra  12$                       notany, rbreak, rspan, rmatch, rpad, rlen, rany,
stra  13$                       rnotany, str, and convert.
sunb   1
sunb   2
sunb   3$ 07/24/84     84206     s. freudenberger
sunb   4$
sunb   5$  1. introduce -vadvise- program parameter for s68, to advise unix
sunb   6$     about the expected paging behaviour.  bit 1 sets anomalous
sunb   7$     behaviour during garbage collections, bit 2 set anomalous
sunb   8$     behaviour during execution.  default is 1, i.e. anomalous during
sunb   9$     garbage collection and normal during program execution.
sunb  10$     modules affected: stlini, libini, interp, and grbcol.
sunb  11$  2. implement the foreign interface for s68.
sunb  12$     module affected:  putf1.
sunb  13$  3. change the semantic of the title function:  -title- now never
sunb  14$     causes a page eject but resets the title line and positions the
sunb  15$     line pointer to the last line of the current page.  this implies
sunb  16$     that the next line printed will cause the page eject, and that
sunb  17$     -title- can be invoked as often as one wants without generating
sunb  18$     any actual output.
sunb  19$     module affected:  stltitle.
asca   1
asca   2
asca   3$ 03/05/84    84065     d. shields
asca   4$
asca   5$  1. for s37, add option ascii=0/1 such that ascii=1 causes the
asca   6$     library to maintain strings within the heap in ascii.  this
asca   7$     feature is needed to support the nyu ada/ed ada compiler.  this
asca   8$     mod is conditioned by ascebc, which should be enabled for s37.
asca   9$     modules affected: libini, print2, readnum, readstr, rdname, putr,
asca  10$                       getr, bldsds, bldstr, valli, strli, lpad, rpad,
asca  11$                       and str.
asca  12$     modules added:    ascstr and ebcstr (after getr).
suna   1
suna   2
suna   3$ 02/05/84     84065     s. freudenberger
suna   4$
suna   5$  1. support motorola mc68000 microprocessor on sun workstation.
suna   6$     modules affected: stlini, stllib, stlint, libini, intrp2, and
suna   7$                       grbcol.
suna   8$  2. fix a bug for equality routine in the packed/unpacked tuples.
suna   9$     module affected:  equal.
suna  10$  3. support programmable interface for s32u.
suna  11$     module affected:  callf1.
suna  12$  3. correct and error in the long integer division that generated
suna  13$     a negative zero.
suna  14$     module affected:  divli.
smfd   1
smfd   2
smfd   3$ 09/01/83     83244     s. freudenberger
smfd   4$
smfd   5$  1. expand the q2_witht interpreter case.
smfd   6$     module affected:  intrp1.
smfd   7$  2. correct a typo in the interpreter case q2_soft.
smfd   8$     module affected:  intrp2.
smfd   9$  3. use the new short integer binary file format.
smfd  10$     modules affected: putb1 and getb1.
smfd  11$  4. correct the conversion to mixed tuple:  check that the mixed tuple
smfd  12$     is not expanded beyond its length.
smfd  13$     module affected:  convert.
smfe   1$  5. fix a bug when reading negative reals.
smfe   2$     module affected:  readnum.
smfc   1
smfc   2
smfc   3$ 09/01/83     83244     s. freudenberger
smfc   4$
smfc   5$  1. allocate range sets of the proper form for ambiguous maps.
smfc   6$     modules affected: union, withs, ofa, and convsm.
smfc   7$  2. correct the set intersection routine to follow the copy semantics
smfc   8$     of the optimiser.
smfc   9$     module affected:  intersect.
smfc  10$  3. fix several small bugs in the long integer package.
smfc  11$     modules affected: intrp1, callf1, putf1, getbli, intad2, intsb1,
smfc  12$                       intsb2, and intdiv.
smfc  13$  4. revise the algorithm used for fixli and floatli.
smfc  14$     modules affected: floatli, fixli, ceil, and floor.
smfc  15$  5. add the missing code in str to handle the new long integer format.
smfc  16$     module affected:  str.
smfc  17$  6. fix a bug in the iteration over based subsets.
smfc  18$     module affected:  convsm.
mjsa   1
mjsa   2
mjsa   3$ 08/08/83     83220     s. freudenberger and m. smosna
mjsa   4$
mjsa   5$  1. implement arbitrary precision integer arithmetic.
mjsa   6$     modules affected: intrp1, intrp2, intrp3, eqprim, print2, readnum,
mjsa   7$                       putb1, getb1, gethash, lt, ge, even, addli,
mjsa   8$                       diffli, divli, modli, multli, umin, sabs, ceil,
mjsa   9$                       floor, sfix, sfloat, rand, sign, and sexp.
mjsa  10$     modules added:    uminli, equalli, ltli, evenli, floatli, fixli,
mjsa  11$                       hashli, valli, strli, putbli, getbli, putintli,
mjsa  12$                       getintli, intad1, intad2, intsb1, intsb2,
mjsa  13$                       intdiv, and trlint.
mjsa  14$     modules deleted:  readint and eqlint.
mjsa  15$  2. replace calls to the setl -ge- function in the interpreter by
mjsa  16$     calls to the setl -lt- function, negating the result.
mjsa  17$     modules affected: intrp1 and intrp3.
mjsa  18$     module deleted:   ge.
smfb   1
smfb   2
smfb   3$ 08/08/83     83220     s. freudenberger
smfb   4$
smfb   5$  1. add a new program parameter that gives the maximum size to which
smfb   6$     the heap may grow:  the new program parameter is
smfb   7$         max_heap=0/0        limit the growth of the heap by this value
smfb   8$     module affected:  libini.
smfb   9$  2. read and write an additional heap slice.  initially, the
smfb  10$     additional slice excludes the dead block following the last run-
smfb  11$     time names string block.  otherwise, it is a zero-length dummy
smfb  12$     slice.
smfb  13$     modules affected: rdhea2 and wrhea2.
smfb  14$  3. generalise the interpreter cases for q2_oft, q2_ofts, q2_soft, and
smfb  15$     q2_caset:  the modified code can handle any integer, not only
smfb  16$     short integers.  this modification was made possible after the
smfb  17$     implementation restricted tuple indeces to short integers.
smfb  18$     modules affected: intrp2 and intrp3.
smfb  19$  4. sem fills in the complete jump table for case maps represented as
smfb  20$     tuples.  this simplifies the q2_caset interpreter case.
smfb  21$     module affected:  intrp3.
smfb  22$  5. add a new conditional branch q2_ifasrt with the semantics to
smfb  23$     branch to a1 if getipp('assert=1/2') = 0.
smfb  24$     modules affected: intrp2 and opnam1.
smfb  25$  6. eliminate a redundant share bit test in less and lessf.
smfb  26$     modules affected: less and lessf.
smfb  27$  7. set the is_multi and is_om bits correctly for trivial mmap results
smfb  28$     for less and from.
smfb  29$     modules affected: less and froms.
smfb  30$  8. expand the cardinality update for tuples inline, since the
smfb  31$     okneltr routine is very slow on long tuples.
smfb  32$     modules affected: frome and sof.
smfb  33$  9. modify mixed tuples correctly:  move omega specifier, not symbol
smfb  34$     table index.
smfb  35$     module affected:  frome.
smfb  36$ 10. include a type check for the first argument of a membership test
smfb  37$     for indirect strings.
smfb  38$     module affected:  member.
smfb  39$ 11. correct an error for 'str 9.99....9' where the real was not
smfb  40$     checked for range after rounding.
smfb  41$     module affected:  str.
smfb  42$ 12. correct an error in the coversion routine for conversions between
smfb  43$     odd tuples.  also, do not reset the share bit after conversion
smfb  44$     from element-of-base format.
smfb  45$     module affected:  convert.
smfb  46$ 13. include a length test for tuples whose ft_lim is non-zero:
smfb  47$     a tuple t1 whose minimum length is less than the minimum length of
smfb  48$     some other tuple t2 is not more general than t2.
smfb  49$     module affected:  moregen.
smfb  50$ 14. compact the printed output for error messages:  skip only one line
smfb  51$     before and after the error message;  print the error message in
smfb  52$     one line.
smfb  53$     modules affected: err_q2 and err_proc.
smfb  54$ 15. insert the missing initialisation for q2_trccalls and q2_trcsym in
smfb  55$     the operator names table.
smfb  56$     module affected:  opnam2.
smfb  57$ 16. delete the obsolete code in varid since code files are
smfb  58$     incompatible.
smfb  59$     module affected:  varid.
smfa   1
smfa   2
smfa   3$ 12/16/82     82350     s. freudenberger
smfa   4$
smfa   5$  1. run-time names are stored differently:  see compl for an explana-
smfa   6$     tion.  this version is upwards compatible for all implementations.
smfa   7$     module affected:  errproc and varid.
smfa   8$  2. the leading character for long atoms on output has been corrected.
smfa   9$     module affected:  print2.
smfa  10$  3. the semantic of the npow1 routine has been changed:  it now
smfa  11$     returns a count of the number of specifiers it pushed onto the
smfa  12$     stack, and relies on npow and pow to form the proper set.  this
smfa  13$     avoids using set-unions in the pow routine.
smfa  14$     modules affected: pow, npow, and npow1.
      22
      23
      24$ 08/12/82     82224     s. freudenberger
      25$
      26$  1. the q2 interface has been changed:  several environment variables
      27$     not included in the past have been included, so that all variables
      28$     needed to resume execution after a dump has been written are now
      29$     part of the q2 file.  this required that several variables were
      30$     moved from nsintp to nsgparam.
      31$     modules affected: rdhea1, rdhea2, interp, intrp3, and intrp4.
      32$  2. the q2 opcodes have been updated:  all aliases and unused codes
      33$     have been eliminated.
      34$     module affected:  intrp1, intrp3, intrp4, opnam1, and opnam2.
      35$  3. procedure linkage has been modified:  the relevant opcodes specify
      36$     the low-core address of the block to be moved, instead of the
      37$     high-core address.
      38$     module affected:  intrp4.
      39$  4. the statement trace prints its message starting in column 1
      40$     instead of column 7.
      41$     module affected:  intrp4.
      42$  5. remote set union expands the first set to the length of the second
      43$     if so required, and not to the length of the second operand + 1.
      44$     module affected:  unrset.
      45$  6. the binary read routine test the binary header code for validity
      46$     and prints an error message if it is found to be invalid.  in the
      47$     past, this would yield a little bad goto error.
      48$     module affected:  getb1 and errfatal.
      49$  7. the argument sequence for the q2_entry, q2_exit, and q2_undo
      50$     instructions has been changed:  the code address now occupies the
      51$     codea1 field of the first quadruple (recall that all other code
      52$     addresses use this field, which is larger than the remaining
      53$     fields).
      54$     module affected:  intrp4.
      55
      56
      57$ 06/15/82     82166     s. freudenberger
      58$
      59$  1. code sequences for setl division check for zero divisor.
      60$     modules affected: interp1, div, and slash.
      61$  2. the variable len has been removed from the nsintp (interpreter)
      62$     nameset, since it caused naming conflicts with the setl len
      63$     function in connection with machine code generation.  uses of len
      64$     have been replaced by temp.
      65$     modules affected: interp and interp2.
      66$  3. the pageof macro for the dec vax vms implementation (s32) has been
      67$     corrected to reflect the fact that little allocates array(0), even
      68$     though it defines arrays to be one-origined.
      69$     module affected:  (remote text inclusion).
      70
      71
      72$ 06/01/82     82152     s. freudenberger
      73$
      74$  1. the interpreter has been modified to eliminate common
      75$     subexpressions for q2_add and q2_lessls.
      76$     module affected:  intrp1.
      77$  2. the interpreter has been modified to attempt a short integer
      78$     addition (subtraction) before calling the general add-long-integer
      79$     (subtract-long-integer) routine.
      80$     module affected:  intrp1.
      81$  3. the interpreter has been modified to use the image of the template
      82$     block, rather the the sample value of the image form, to delete
      83$     the image for 'f' in 'f lessf x' where 'f' is a local map.
      84$     (i.e. q2_lessflm.)  this implies that local forms on plex bases
      85$     cannot use this code.
      86$     module affected:  intrp1.
      87$  4. the interpreter has been modified to use the zero'th component of
      88$     the image tuple of 'f' in 'f lessf x' where 'f' is a remote map.
      89$     (i.e. q2_lessfrm.)
      90$     module affected:  intrp1.
      91$  5. we check the otype rather than the type of the index in the
      92$     q2_ofcl interpreter case.
      93$     module affected:  intrp2.
      94$  6. the interpreter has been corrected to perform 's(x) := y'
      95$     correctly if 's' and 'y' are strings, 'x' a short integer, and
      96$     '#y' > 1.  (i.e. q2_sofcl.)
      97$     module affected:  intrp3.
      98$  7. the semantics of the q2_checktp and q2_checki1 operations have
      99$     been modified, to account for the use of ft_low.
     100$     module affected:  intrp3.
     101$  8. 'cur_stmt' is only set under 'st' conditional assembly symbol,
     102$     since only code conditioned by 'st' uses this variable.
     103$     (i.e. q2_stmt.)
     104$     module affected:  intrp4.
     105$  9. the member routine has been modified to use knuth's linear string-
     106$     matching algorithm for string comparisons.  this eliminates the
     107$     restriction that #s1 = 1, type s1 = type s2 = string in 's1 in s2'
     108$     module affected:  member.
     109$ 10. the 'read' routine allocates an f_uset for all set forms, since
     110$     setform does not perform set/map test recursively, yet rset1/rset2
     111$     do.  this can lead to problems if what first looked like a map
     112$     turns out to be a set.
     113$     module affected:  read.
     114$ 11. the error messages for the fortran (foreign) interface have been
     115$     added.  they all used to be err_fatal.54:  error in experimental
     116$     feature.
     117$     modules affected: getf, getf1, callf, callf1, callf2, putf, putf1,
     118$                       and err_fatal.
     119$ 12. the 'convert' routine has been modified to reflect the change
     120$     w.r.t. the ft_low/ft_nonzero field for short integer forms.
     121$     module affected:  convert.
     122$ 13. the (never used) conditional assembly group 'simp' has been pulled
     123$     out of the interpreter.  where appropriate, and new conditional
     124$     symbol 'dead' has been used to mark code which currently can never
     125$     be reached.
     126$     modules affected:  intrp1, intrp2, intrp3, and withm.
     127
     128
     129$ 03/16/82     82075     s. freudenberger
     130$
     131$  1. several library routines have been renamed to remove problems they
     132$     caused for various implementations.  see compl.q2macs for details.
     133$  2. ltlini actually expects a parameter.  this has been corrected.
     134$     module affected:  stlint.
     135$  3. the q2 opcodes q2_eqtrue, q2_eqfalse, q2_eqif, q2_eqifnot,
     136$     q2_goif, and q2_goifnot are never emitted:  a call to err_fatal
     137$     has been inserted for the appropriate interpreter cases.  these
     138$     opcodes should be removed as time permits.
     139$     modules affected: interp1 and interp3.
     140$  4. the interpreter case for untyped comparisons have been corrected.
     141$     opcodes affected: q2_geui, q2_geur, and q2_ltur.
     142$     module affected:  interp1.
     143$  5. the range test for the q2_sofrm interpreter case has been
     144$     corrected.
     145$     module affected:  interp2.
     146$  6. the backtracking opocodes have been revisited, and an interpro-
     147$     cedural backtracking bug been corrected.  this bug occurred if
     148$     we failed back into a procedure which still had more than one
     149$     ok block live.
     150$     module affected:  interp4.
     151$  7. currently, the is_neltok bit is never set:  this bit is planned
     152$     to be set by the optimiser, but this optimisation has not yet
     153$     been implemented.  since on several machines, the .nb. operator
     154$     is quite expensive, we removed the code to compute the cardina-
     155$     lity of the result for several remote-set routines.
     156$     modules affected: unrset, inrset, and difrset.
     157$  8. during the marking phase, the garbage collector sets a flag if
     158$     the heap contains base blocks.  if not base blocks are found, we
     159$     do not call the base compaction phase gbcmp.
     160$     modules affected: grbcol and grbmrk.
     161$  9. the call to the little remarkl has been deleted from err_proc.
     162$     module affected:  errproc.
     163$ 10. the opnames for the is_type operator have been corrected to follow
     164$     the general convention to use the operator name without the
     165$     'q2_' prefix.
     166$     module affected:  opname1.
     167$ 11. a new function opname has been added after opnam2.  it returns
     168$     for a given opcode the operation name as a sds-string with no
     169$     trailing blanks.
     170$     module affected:  dinst.
     171$     module added:     opname.
     172$ 12. var_id has been corrected to remove trailing blanks if its second
     173$     argument equals zero.
     174$     module affected:  varid.
     175
     176
     177$ 02/01/82     82032     s. freudenberger
     178$
     179$  1. version 81300 introduced a bug into the sof routines for string
     180$     operands.  this has been corrected.
     181$     module affected:  sof.
     182
     183
     184$ 02/01/82    82032     d. shields
     185$
     186$ use r32 conditional symbol for standard 32-bit fields.
     187$ this replaces the field definitions for s32, s37 and s47.
     188
     189
     190$ 01/29/82    82029     d. shields
     191$
     192$  1. revise envmhl to support mhl_static, mhl_dynamic and
     193$     mhl_s66. mhl_dynamic calls envdsl to get dynamic memory
     194$     limit and envdsa to allocate dynamic storage.
     195$     for s32v, envdsv is needed as well.
     196$  2. delete '.=include s32q2f', etc., as part of r32 edit.
     197
     198
     199$ 01/20/82     82015+    d. shields
     200$
     201$  1.  delete extra declaration for getapp_len for s47.
     202$  2.  fix misplaced vadvise declaration for s32u.
     203$  3.  rename open to sopen, close to sclose, any to sany, and
     204$      rand to srand. this is needed to avoid conflicts with c
     205$      library procedures for s47, and is harmless to other
     206$      implementations.
     207$  4. use envssi in little for s47.
     208$ (these corrections fix minor errors in 82015 version, so i did
     209$ not change program_level).
     210
     211
     212$ 01/15/82     82015     s. freudenberger & d. shields
     213$
     214$  1. libini has been modified to print the phase header to the terminal
     215$     whenever the new control card parameter 'termh=0/1' is set.
     216$     new control card parameter:
     217$         termh=0/1           print phase header on the terminal file
     218$     module affected:  libini.
     219$  2. the backtracking pointers are initialised to zero, thus avoiding
     220$     potential problems if storage is not initialised to zero by
     221$     default.
     222$     module affected:  interp.
     223$  3. backtracking interpreter cases have been corrected to initially
     224$     reserve all the storage they need, thus causing garbage collection
     225$     to occur before the instruction is started.
     226$     module affected:  intrp4.
     227$  4. the 'less' routine has been corrected for 'map less non-pair'.
     228$     the original code would pick-up arbitrary memory locations in
     229$     this case.
     230$     module affected:  less.
     231$  5. the 'dumpds1' routine has been enhanced to check for the '0'
     232$     file title, and to avoid the writing of a heap image to the sink.
     233$     module affected:  dumpds1.
     234$  6. add option 'socase=0/0' to select output case returned for
     235$     strings. socase=0 requests the default case, socase=1 requests
     236$     lower case, and socase=2 requests upper case. currently this is
     237$     implemented only for the 'type' operator, though later extension
     238$     to formatted output may be desirable. this option only has meaning
     239$     in mixed-case implementations.
     240$  7. add option 'vadvise=0/1' for s32u to describe paging behavior to
     241$     vadvise. if bit 1 is set, va_anom will be set during garbage
     242$     collections; if bit 2 is set, va_anom will be be outside garbage
     243$     collections. otherwise, va_norm is used.
     244$  8. use same envmhl text for both s32u and s32v.
     245
     246
     247$ 11/29/81    81333     d.shields
     248$
     249$  1. support s47: amdahl uts (universal timesharing system).
     250$     this implementation runs on s37 architecture using an operating
     251$     system very close to unix (v7), and uses the ascii character set.
     252
     253
     254$ 10/27/81     81300     s. freudenberger and d. shields
     255$
     256$  1. the q2 interface has been formalized:  a total of six routines
     257$     read and write a standard q2 file, and a seventh routine
     258$     checks a q2 file to determine whether it is in the correct
     259$     format.
     260$     the routines rdheap, rdheap1, and rdheap2 read the entire
     261$     heap, the environment block, and the heap slices, resp.
     262$     the routine chkq2f checks the q2 file format.
     263$     the routines wrheap, wrheap1, and wrheap2 write the entire
     264$     heap, the environment block, and the heap slices, resp.
     265$     modules affected: libini and dumpds1.
     266$     modules added:    rdheap, rdheap1, rdheap2, chkq2f, wrheap,
     267$                       wrheap1, and wrheap2.
     268$  2. for the dec vax vms version we now allocate the heap dynamically.
     269$     the initial 'prog lib' containing all global declarations has
     270$     been canged into the subroutine stlini.
     271$     the new main program has also been renamed to stllib, to
     272$     avoid a logical name conflict on the local vax.
     273$     to determine the amount of space available for the heap without
     274$     using space needed to allocate i/o buffers, the following
     275$     control card parameter has been introduced:
     276$         nof=5/5         number of open user files
     277$     modules affected: libini and getspace.
     278$     module deleted:   lib.
     279$     modules added:    stlini and stllib.
     280$  3. the setl-fortran interface has been implemented for the
     281$     s32, s37, and s66 versions.
     282$     the interface uses a communication area which is kept as a
     283$     tuple in the setl heap as the symbol intf:  s_intf replaces
     284$     s_spare1.
     285$     the actual call to fortran is done by the new built-in function
     286$     callf, for which a new q2 opcode was needed.
     287$     the new conditional assembly symbol defenv_envfor marks the
     288$     relevant code.
     289$     modules affected: stlini, rdheap1, wrheap1, interp4,
     290$                       getf, putf, err_fatal, and opnam2.
     291$     modules added:    stlint, getf1, callf, callf1, callf2,
     292$                       and putf1.
     293$  4. for the dec vax vms version (s32), using the vms crmpsc system
     294$     service, we provide the option to create and use file formats
     295$     which allow to map the heap image directly into the virtual
     296$     address space, thus eliminating the need to read the heap before
     297$     execution starts.  this work introduced the following new control
     298$     card parameters:
     299$         q2init=0/1      initialisation type:
     300$                             0:    standard initialisation: read heap
     301$                             1:    use mapped heap
     302$                             2:    create mapped heap and section files
     303$         q2e=q2e/        name of q2 environment file
     304$         q2h=q2h/        name of q2 heap file
     305$         hftrace=0/1     trace relevant procedures
     306$     this work introduced the new conditional symbol hf, used to mark
     307$     the code related to the heap file option.
     308$     see compl.mhfpkg for a more detailed account.
     309$     modules affected: stlini, libini, and errfatal.
     310$     modules added:    hfcrst and hfmapr.
     311$  5. the nameset io has been renamed to nameset nsio, to follow the
     312$     standard practice to start all nameset names with the letters ns.
     313$     module affected:  stlini.
     314$  6. the sof routine case for indirect character strings has been
     315$     corrected, after the last correction set corrupted it:  the
     316$     variable t is the stack top pointer and should never be used
     317$     as the variable name of a temporary.
     318$     module affected:  sof.
     319$  7. eof now works after get and getb statements.
     320$     modules affected: stlini, getr, and getb.
     321$  8. the cardinality operator inside error messages has been changed
     322$     from its old syntax, namely ?, to its current syntax, namely #.
     323$     modules affected: errom, errtype, and errmisc.
     324$  9. the errproc routine has been modified to check more carefully
     325$     that a heap image actually exists (has been read) before trying
     326$     to retrieve information from it (which might cause an access
     327$     violation if the heap has not yet been allocated).
     328$     modules affected: libini, and errproc.
     329$ 10. the reserved words 'spec' and 'unspec' have been deleted.
     330$     modules affected: interp4 and opnam2.
     331$     modules deleted:  specr and unspec.
     332$ 11. move the string primitive definition section from module
     333$     libpl.stlini to compl.strpkg.
     334$     module affected:  stlini.
     335
     336
     337$ 06/24/81     81175     s. freudenberger
     338$
     339$  1. we implemented part of a dynamic symbolic debugging feature.
     340$     for this purpose, we added three control card parameters:
     341$     debug=0/1  enables/disables the debugging feature.
     342$     strace=0/1 is equivalent to an initial trace statements, and
     343$                also sets the debug flag.
     344$     ctrace=0/1 is equivalent to an initial trace calls, and also
     345$                sets the debug flag.
     346$     modules affected: lib, libini, interp, interp4, and dumpds1.
     347$  2. the interpreter cases for of on tuples, ie. q2_oftoks, q2_oftok,
     348$     q2_oft, and q2_ofts, have been corrected disallow a2 to be omega.
     349$     module affected:  interp2.
     350$  3. we added the code for the new q2 opcodes (see compl for a list
     351$     and explanations).
     352$     modules affected: interp3, interp4, errtype, opnam1, and opnam2.
     353$  4. the member routine has been corrected not to assume that the nelt
     354$     field of a tuple data block and the ss_len field of an indirect
     355$     string data block have the same position within the data block.
     356$  5. some corrections were misplaced in the of and sof routines w.r.t.
     357$     the dereference operation for the tuple index.  this has been
     358$     taken care of.
     359$  6. we modified the convert routine to allow conversions from general
     360$     to element_of_plex_base, provided the input actually is an
     361$     element of the proper plex base.
     362$  7. we corrected the convert routine to reset the stack pointer after
     363$     an error has occured.
     364$  8. the putvar routine has been modified to check for plex objects
     365$     before it calls the print routine:  this is needed, because we
     366$     cannot iterate over a plex object, and thus cannot print it.
     367$  9. the putvar routine has been modified so that no warnings for
     368$     temporary overflow will be printed anymore by little.gen.
     369
     370
     371$ 08/20/81     81232     s. tihor
     372$
     373$  1. adjust even and odd so that untyped cases and the even routine
     374$     handle negative numbers correctly.
     375
     376
     377$ 09/04/81     81043     s. freudenberger
     378$
     379$  1. the addition routine has been modified to always copy strings.
     380$  2. the multiplication routine has been stripped of an incorrect
     381$     optimisation:  if # i2 < # i1, the sets used to be swapped for
     382$     greater efficiency.  this violated assumptions made by the
     383$     code generator w.r.t. the setting of the copy flag, and under
     384$     special conditions no copy occured though it was needed.
     385$  3. the tuple index needed to be dereferenced in the of and sof
     386$     routines.
     387$  4. the conversion routine (convert) has been corrected to do the
     388$     range check for short integers correctly.  namely, if the ft_lim
     389$     field of the form table entry is zero, we can not check that the
     390$     the value does not exceed the range.
     391$  5. the moregen routine has been modified to handle element-of-base
     392$     forms and mmap forms correctly.
     393
     394
     395$ 04-09-81     81099     s. tihor
     396$
     397$ 1. update the q2 format to include the magic number and time stamp as
     398$    integers. move error messages to separate error routine err_q2.
     399$    add deck err_q2 containing same.
     400$ 2. add 20 spare variables for future expansions
     401$ 3. add q2 op code q2_goif, q2_goifnot, q2_eqif, q2_eqifnot for boolean
     402$    test/if split.
     403$ 4. add q2 ops q2_nins, q2_ninu.
     404$ 5. split q2_lessflm into q2_lessflsm and q2_lessflmm
     405$ 6. split q2_lessfrm into q2_lessfrsm and q2_lessfrmm
     406
     407
     408$ 11/24/80     80308     s.tihor and d.shields
     409$
     410$  1. make open a boolean function which returns true for
     411$     successful open and false for failure.
     412$  2. get the terminal (error log) file name from little via namesio
     413$  3. check code file date stamp
     414
     415
     416$  12/05/80     80340     d. shields
     417$
     418$  1.  change lc code to mc code general master case correction
     419
     420
     421
     422$ 12/02/80     80337     s. freudenberger
     423$
     424$  1. the interpreter cases for q2_lessflm and q2_lessfrm as well
     425$     as the lessf routine have been corrected to treat the omega-
     426$     image for based m-maps correctly.  (ie. reset the is_om bit,
     427$     set the is_multi bit of the om_image(form)).
     428$  2. the set member ship routine map cases dereferences the pair as
     429$     appropriate.  it also checks the components for not-omega.
     430$  3. the getr routine has been corrected to store the string
     431$     specifier back into the argument specifier after a record
     432$     has been read.
     433$  4. the endop and send routines have been modified to dereference
     434$     their argument, if required.
     435$  5. an error in the correction of 80310.14 has been corrected.
     436$     (update of err_proc routine to prevent recursive call to snap)
     437
     438
     439$ 11/05/80     80310     s. freudenberger
     440$
     441$  1. the interpreter cases for q2_lessflm and q2_lessfrm have
     442$     been corrected to set the image to the proper omega value.
     443$  2. the interpreter cases for q2_dom and q2_range have been
     444$     modified to pass the form of the result set (ie. the third
     445$     argument) to the corresponding library routines.
     446$  3. the interpreter cases for q2_savel, q2_clearl, and q2_entry
     447$     have been corrected to set the local variables to omega.
     448$  4. the interpreter case for q2_dexit has been corrected to
     449$     swap the routine parameters from the proper stack offset.
     450$  5. the equality routine general map case has been corrected
     451$     to to branch on the proper test for null range sets of
     452$     multi-valued maps.
     453$  6. the equality routine based map case has been corrected
     454$     to save the pointer to the second set in the stacked
     455$     variables before starting the comparison.
     456$  7. the union routine add_image case has been corrected to
     457$     check for declared single-valuedness of the first map
     458$     if the second map image is multi-valued.
     459$  8. the sof and sofa routines has been changed to assume that the
     460$     first argument (the map) can be used destructively.
     461$  9. the fval and sfval routines had their packed map cases
     462$     corrected.
     463$ 10. the tupform routine has been modified so that is does not
     464$     call the sof routine anymore.
     465$ 11. the domain and range routines have been modified to accept
     466$     any map type, and to return any set type.  the form of the
     467$     result is passed as a second argument.
     468$ 12. the grbcol routine has been corrected so that the variable
     469$     gitotal is word-sized.
     470$ 13. the static heap menagement routine (envmhl) has been modi-
     471$     fied so that it checks the variable max_heap_dim for the
     472$     maximum heap dimension, rather than to use the constant
     473$     heap_dims.  to check a variable in the external nameset
     474$     nsheap allows this nameset to be changed easily to provide
     475$     for different maximum heap sizes, and thus for different
     476$     sizes of the setl system.
     477$ 14. the error processing routine err_proc has been modified
     478$     to check and update the global variable eitotal.  this
     479$     prevents repeated (recursive and hence undefined) calls
     480$     to this routine when we abort due to insufficient heap
     481$     space (-main storage pool exhausted-).
     482$ 15. the snap routine had its local variable prev_snapno dele-
     483$     ted.  after change (14) above, it should not be needed.
     484
     485
     486$ 09/08/80     80252     s. freudenberger
     487$
     488$  1. the sof routine has been corrected to store the range set
     489$     of a multi-valued map in the required form.
     490
     491
     492$ 08/18/80     80231     s. freudenberger
     493$
     494$  1. the q2_withus interpreter case has been corrected:  it was
     495$     wrong for a1 = a2.
     496$  2. the terminal output for error messages has been shortened.
     497
     498
     499$ 08/01/80     80214     s. freudenberger
     500$
     501$  1. the code pointer (codep) has been moved into the nameset
     502$     nsgparam.  consequently no declaration is needed in member
     503$     lib anymore.
     504$  2. the conditional assembly section has been moved into compl,
     505$     and is included into member lib.
     506$  3. several small errors have been corrected in the new str
     507$     routine.
     508$  4. a systematic bug in the conversion routine has been
     509$     corrected:  conversion where the difference of the forms
     510$     was restricted to the setting of the ft_hashok and/or
     511$     ft_neltok bits were done incorrectly.  also, conversions
     512$     between s- and m-maps with equal ft_type- and ft_elmt-
     513$     fields were not handled properly.
     514$  5. the setting of hashs and nelts during conversion also
     515$     has been cleaned up (ie. corrected where found to be done
     516$     improperly.)
     517$  6. a misplaced line in member errfatal has been moved to its
     518$     proper place.
     519
     520
     521$ 07/10/80     80192     s. freudenberger
     522$
     523$  1. conditional assemblies env_gss and env_pss have been intro-
     524$     duced, indicating whether the routines envgss and envpss are
     525$     defined in the environment.  the setl get and put functions
     526$     have been implemented using the envgss and envpss routines.
     527$     if these two routines are not defined, a fatal error message
     528$     'feature not implemented' is printed.
     529$  2. the globals cb_string and sb_string (for curley-braces and
     530$     square-brackets) have been renamed sb_string and tb_string
     531$     (for set braces and tuple brackets).   also, the (related)
     532$     globals lxx_string and rxx_string have been redefined to
     533$     lyy_char and ryy_char, resp.
     534$  3. if the title control card parameter is selected, an initial
     535$     line is printed on the terminal file: "start cims.setl.lib.."
     536$  4. the q2_file is released immediately after it is read (in
     537$     libini).
     538$  5. the following interpreter cases have been added:
     539$           q2_nincs, q2_gonincs, and q2_error
     540$  6. the following interpreter cases have been eliminated:
     541$           q2_goimp and q2_gonimp
     542$  7. the string file has been eliminated.
     543$  8. the str routine has been implemented newly.
     544
     545
     546$ 07/08/80     80190     s. freudenberger
     547$
     548$  1. the ssbstt routine has been corrected so that, if the length
     549$     of the result tuple is less than the length of the input tuple,
     550$     and the input tuple is used destructively, then the length of
     551$     the result tuple is set properly.
     552$  2. the interpreter case for q2_type has been corrected to handle
     553$     t_elmt specifiers correctly.
     554$  3. the interpreter case for q2_gonnl has been corrected to return
     555$     after the code pointer is updated, rather than to branch to
     556$     the nxt label (where the code pointer would be updated, thus
     557$     skipping the first instruction after the jump).
     558$  4. the intepreter cases for q2_ge, q2_lt, q2_goge, and q2_golt have
     559$     been corrected to check for omega-integers before branching to
     560$     the respective integer inline cases.
     561$  5. the interpreter case for q2_locate has been corrected to return
     562$     a t_oelmt specifier for omega values.
     563$  6. the interpreter case for q2_time has been modified to return
     564$     an integer, rather than a short integer, to avoid the problem
     565$     of overflow.
     566$  7. the addition and multiplication routines have been modified to
     567$     handle mixed tuples properly.
     568$  8. the withs routine has been modified to signal an error on
     569$     omega sets.
     570$  9. the sof routine has been modified to treat str1(i) := str2 as
     571$     str(i..i) := str2 if #str2 /= 1.
     572$ 10. the title function has been revised to implement the new
     573$     semantic definition.
     574$ 11. the cardinality for the result tuple in tup(i..j) is set
     575$     properly.
     576$ 12. a check has been added to the ssubst routine to assert
     577$     1 <= a2 <= a3+1 <= #a1+1 for strings.
     578
     579
     580$ 06/20/80     80172     s. freudenberger
     581$
     582$  1. a call to the dumpds1 routine has been added in the errproc
     583$     routine for s32 to circumvent poor exception handling of s32
     584$     little system.
     585$  2. the find_stmt routine has been corrected to look up to ca_org for
     586$     the next stmt quadrupel.
     587$  3. a test has been added to the nullp routine to check for the
     588$     possibility of insufficient heap space for garbage collection.
     589$     thought this condition should never arise, let's play it save.
     590$  4. the blksz routine has been modified to abort on invalid htype's.
     591$  5. a bug related to the global string specifiers has been corrected.
     592$  6. since the valr routine tends to execute forever, the system now
     593$     aborts on entry to valr.
     594$  7. the snap routine has been modified to only attempt to print the
     595$     variable values if the heap is properly formed, ie. not during
     596$     a garbage collection.
     597$  8. the gethash routine has been modified to truncate the hash code
     598$     to hcsz bits before it returns.  this is needed since little's
     599$     attitude that a size statement specifies a minimum size does
     600$     not have the desired result.
     601$  9. a test has been added to the expand routine to check that
     602$     (a.) the lognhedrs field does not overflow, and (b.) at most
     603$     2 ** hcsz hash headers are allocated.
     604$ 10. the interpreter case for q2_host has been corrected.
     605$ 11. several routines have been modified to actually execute a little
     606$     assert statement when the (implicit) assumption is made that
     607$     long integers are exactly one word long.
     608$ 12. the printa, reada, put, and get routines now interpret the
     609$     nullstring as the file name for the standard output and
     610$     input files, resp.
     611$     nb. no changes have been made to the open and close routines,
     612$     so one should expect problems when these routines are called
     613$     with a nullstring as file name.  the result of such a call is
     614$     undefined.
     615$ 13. the lexclass for alphabetics has been initialized to read_name.
     616$ 14. the interpreter cases for q2_inr and q2_ninr have been corrected.
     617
     618
     619$ 05/29/80     80150     s. freudenberger
     620$
     621$  1. the hash table header data structure introduced with 80130 has
     622$     been incorporated into the compiler.
     623$     decks affected: equal, copy1, delete, nullset, expand,
     624$         contract, dom, grbmrk
     625$  2. hash table contraction for bases has been enabled, a consequence
     626$     of hashing changes done 79351.
     627$     deck affected:  gbcmp3
     628
     629
     630$ 05/27/80     80148     s. freudenberger
     631$
     632$  1. the checkptr routine has been corrected to scan only
     633$     the heap proper, skipping the symbol table and the like.
     634$  2. the following interpreter cases have been corrected to
     635$     use the proper field extract macros:
     636$         q2_eqform1, q2_eqform2, q2_eqform3, q2_deref, q2_deref1
     637$  3. the q2_locate interpreter case has been modified to handle
     638$     the omega case properly.
     639$  4. the equal and eqsub routines have been modified:  eqsub has
     640$     been renamed to eqlrs (equality of local-remote sets),
     641$     restricting the arguments such that the first argument has
     642$     to be the local set, and the second argument the remote set.
     643$     the loop body in this routine has been rewritten, avoiding
     644$     two calls to the fval routine.  this should speed up subset
     645$     equality tests considerably.
     646$  5. the equality routine has been modified to avoid unneeded
     647$     computations of hash and nelts:  hash fields are only compared
     648$     if they are available (is_hashok = yes), and the cardinality
     649$     is not computed for based sets and maps if they are based on
     650$     the same base.  the needed adjustments to the eqrs have been
     651$     made as well.
     652
     653
     654$ 05/09/80     80130     s. freudenberger
     655$
     656$  1. the interpreter cases q2_nextt and q2_nextut have been
     657$     changed so that they don't skip embedded omegas in
     658$     tuples.  this change results in equivalent executions
     659$     of the interpreter cases mentioned and the corresponding
     660$     cases in the next routine.
     661$  2. the variable om in the frome routine has been renamed
     662$     om_val.  the old name, for some unknown reason, caused the
     663$     setl system constant om to be destroyed.
     664$  3. the len and rlen routines have been modified to use newly
     665$     allocated string specifiers for the result.  this problem
     666$     would only occur on machines which store string specifiers
     667$     indirectly, and only if the string specifier was shared.
     668$  4. two error messages in the err_om routine were corrected.
     669$     five error messages in the err_type routine were corrected.
     670$  5. the is_ebfree flag has been deleted.
     671$  6. the q2_query and q2_isprim operators have been eliminated.
     672$  7. the modes for which the setl from and arb operators are
     673$     defined has been restricted to set_modes.
     674
     675
     676$ 04/11/80     80102     d. shields
     677$
     678$  1. if appropriate, permit tab in addition to blank as separator
     679$     on text input.
     680$  2. implement is_xxx predicates.
     681$  3. if appropriate, permit lower case in identifier input.
     682$  4. fix error in initializing mvc1 and mvc1 specifiers.
     683$  5. supply missing 'ctuc' declaratinon in 'rdbool'.
     684$  6. add miscellaneous changes to get setl running on s10.
     685$  7. modify heap allocation strategy so that heap allocated from
     686$     large 'static' array on all implementations except s66.
     687$  8. modify getr to reflect available routines for reading in
     688$     text line. this area somewhat confused due to uncertainty
     689$     when i/o will be cleaned up.
     690$  9. provide figures on garbage collector in performance (lcs)
     691$     statistics.
     692$ 10. delete cdc update yankdeck directives.
     693$ 11. fix error in random routine.
     694$ 12. delete 'part 5' used to build 'student' version.
     695$     this was used only for s66, and is no longer appropriate.
     696
     697
     698$ 04/09/80     80100     s. freudenberger
     699$
     700$ 1. the set << [om, 1] >> is considered legal, but not convertible
     701$    to a map.  this required additional tests in the withs, rset1,
     702$    rset2, setf1, and isamap routines.
     703$ 2. there was an uninitialized flag in arbs which caused the result
     704$    of arbs << [1, 2] >> to be omega.
     705$ 3. the frome routine did not store the proper omega into the dele-
     706$    ted component of a mixed tuple.  also, the nelt of mixed tuples
     707$    was not updated correctly.
     708$ 4. the sof routine did not update the nelt of a tuple correctly in
     709$    t(#t) := om;
     710$ 5. the ssbsts routine (sinister string substring) incorrectly
     711$    specified the length for the third move to the 'move-character'
     712$    macro.
     713$ 6. the share bit of the embedded component is set in the initnpow
     714$    routine.
     715
     716
     717$ 02/04/80     80035     s. freudenberger and d. shields
     718$
     719$ 1. implement unary operators acos, asin, atan, char, cos, exp,
     720$    log, sin, sqrt, tan and tanh.
     721$ 2. implement binary operators atan2 and interrogation (?).
     722$ 3. implement type predicates is_atom, is_boolean, is_integer,
     723$    is_map, is_real, is_set, is_string and is_tuple.
     724$    change prim to is_primitive.
     725$ 4. add procedure host() to provide means for adding
     726$    implementation- or site-dependent features.
     727$ 5. change the name of the set bracket control card parameter from
     728$    'cb' (curley bracket) to 'sb' (set braces), and the name of the
     729$    tuple bracket control card parameter from 'sb' (square bracket)
     730$    to 'tb' (tuple bracket).
     731$ 6. a conditional assembly 'lc' has been added to control upper/lower
     732$    case equivalency.
     733$ 7. two routines have been added to read identifier-type strings and
     734$    booleans:  rdname and rdbool.
     735$ 8. two control card parameters have been added to control listing
     736$    options:  'lcp' to identify the setl system on the terminal file
     737$    as well as print the complete parameter string on the standard
     738$    output file;  and 'lcs' to print final execution statistics.
     739$ 9. the default for the snap control card parameter has been set to 0.
     740$ 10. the interpreter case for q2_dump has been changed to increment
     741$     the code pointer before the dump is written.  this allows for
     742$     a crude 'save' feature, as the file written is compatible with
     743$     the q2 file, and thus can be read as code file.
     744$ 11. 'sfval' has been corrected for local packed maps.
     745$ 12. 'with' has been corrected to handle mixed tuples correctly.
     746$ 13. atoms are preceded by a number sign (instead of a question mark).
     747$ 14. sinister substrings on strings are done using the 'move-character'
     748$     macro.
     749$ 15. some clean-up changes have been made to 'getspace' and 'libterm'.
     750$ 16. a sizing error has been corrected in 'dumpds1':  the title of the
     751$     dump file is now correctly sized.
     752$ 17. 'varid' has been updated to access the run-time names table
     753$     correctly if names are stored accross several words.
     754$ 18. several error messages have been added, corresponding to changes
     755$     mentioned above.
     756
     757
     758$ 01/21/80     80021     s. freudenberger
     759$
     760$ 1. the form table limit has been increased for the s32.  corresponding
     761$    changes have been made for the s32 q2 fields.
     762$ 2. long character string access has been parameterized differently to
     763$    account for the peculiar way the s32 stores bytes in words.
     764
     765
     766$ 01/17/80     80017     s. freudenberger
     767$
     768$ the layout of the heap has been changed:  snames has been integrated
     769$ into the heap at the low core end, and the run-time symbol table has
     770$ been allocated between the run-time names and the constant  part  of
     771$ the heap.
     772$ modules affected:  libini, grbmrk, adjcode (deleted), dumpds1,
     773$ getspace, snap, putvar, dinst, and varid.
     774
     775
     776$ 01/16/80     80016     s. freudenberger
     777$
     778$ 1. all external names of the library are now unique within the first
     779$    six characters.
     780$ 2. 'unrset' had a correction misplaced.  this has been taken care of.
     781$ 3. 's1(i) := s2' has been modified to check is_string(s2) * #s2 = 1.
     782
     783
     784$ 01/15/80     80015     s. freudenberger
     785$
     786$ 1. the statement trace has been shorthened to one line.
     787$ 2. 'eqprim', 'lt', and 'ge' have been modified to use the new
     788$    compare-logical-character macro (clc).
     789$ 3. the handling of omega has been updated according to the language
     790$    definition in the routines of, ofa, and sofa.
     791$ 4. exptup has been modified to reset the share bit if it had to copy
     792$    the tuple.
     793$ 5. gethash has been modified to use the hash-code-seed macro.  note
     794$    that the current hashing function still is rather ad-hoc, and
     795$    should be subject to review.
     796$ 6. 'ssubsts' and 'ssubstt' have been renamed 'ssbsts' and 'ssbstt',
     797$    resp.  the only remaining external names which are not unique
     798$    when truncated to six characters are thus 'getippr' and 'getsppr',
     799$    which conflict with coresponding external names in the little
     800$    library.
     801$ 7. some optimization has been done in the 'ssbstt' routine, to avoid
     802$    unnecessary copies.
     803$ 8. error messages have been updated and added in correspondence with
     804$    other changes.
     805$ 9. 'sabs' has been augmented for string arguments, and 'schar' has
     806$    been added to the library.
     807
     808
     809$ 12/17/79     79351     s. freudenberger
     810$
     811$ 1. the following routines have been renamed to make their names
     812$    unique within the first six characters:
     813$         interp1 ---> intrp1 ... interp4 ---> intrp4
     814$         nsinterp ---> nsintp
     815$         opname1ns ---> nsopn1 ... opname2ns ---> nsopn2
     816$    this leaves, to the best of my knowledge, the following names
     817$    non-unique within six characters:
     818$         ssubst, ssubsts, ssubstt
     819$         getippr, getsppr (they conflict with little routine names)
     820$ 2. extensible hashing has been implemented.  the following routines
     821$    have been changed substantially to do so:
     822$         equal, locate, augment, expand, contract,
     823$    note that 'gethash' properbly should be modified as well, and that
     824$    further changes should clean up this first crude approach.  further
     825$    more, the duocumentation in the equality routine needs to be
     826$    updated (obsolete comment marked as such)
     827$ 3. the exponetiation routine ('sexp') has been corrected to
     828$    dereference inputs of type element.
     829$ 4. 'lessf' has been corrected to observe the proper copy semantic.
     830$ 5. 'of' has been changed according to the language change that it
     831$    is illegal to index omega.
     832$ 6. 'sof' has been corrected to set the is_multi_ bit for the image
     833$    set of an mmap.
     834$ 7. 'putvar' has been changed to not attempt to print bases.  this
     835$    used to cause a bad go to index in the print routine.
     836$ 8. 'opname1' and 'opname2' have been updated to include the 'eqtrue',.
     837$    etc. cases.
     838
     839
     840$ 11/30/79     79334     s. freudenberger
     841$
     842$ 1. four cases have been added to the interpreter, special handling
     843$    equality test on booleans.
     844$ 2. set/map equality has been corrected in 'equal'.
     845$ 3. 'with' and 'less' have been corrected to observe the proper copy
     846$    semantic on 't_elmt's.
     847$ 4. 'sof' has been corrected to check the type of the second argument
     848$    in the t_istring-case.
     849$ 5. 'putb1' has been enhanced to allow writing of based objects.
     850$ 6. 'augment' has been changed to (a.) never use the hash header of
     851$    a base, and (b.) keep the clash lists of bases sorted.  this
     852$    change became neccessary to allow extensible hashing on bases.
     853$ 7. remote set expansion ('exprset') has been corrected to set rs_maxi
     854$    properly.
     855$ 8. 'gethash' has been corrected to compute the hash code of
     856$    (a.) t_elmt's, and (b.) h_rset's correctly.
     857$ 9. 'arbs <
> = om' has been asserted.
     858$ 10. the error cases for 'domain' and 'range' have been refined.
     859$ 11. various albeit missing error messages have been added.
     860$ 12. 'dumpds1' writes the dump file in the same format as the q2 file.
     861$ 13. 'match' and 'rmatch' have been corrected - another ssi-error !
     862$     also, their deck names have (finally) changed to match the
     863$     routine names.
     864
     865
     866$ 11/12/79     79316     s. freudenberger
     867$
     868$ 1. true and false are printed as #t and #f, resp.
     869$ 2. the binary i/o has been extended to include booleans.
     870$ 3. remote set union has been corrected (fr2.1.012).
     871$ 4. map conversion has been cleaned up.
     872$ 5. 'match' and 'rmatch' have been implemented more efficiently.
     873$ 6. the sizing of 'acs' in fileid has been corrected.
     874$ 7. negative reals are read correctly (fr2.1.015).
     875
     876
     877$ 09/27/79     79269     s. freudenberger
     878$
     879$ 1. missing goto's have been inserted into the interpreter cases for
     880$    q2_fromb..q2_fromeut.
     881$ 2. 'ssubstt' has been corrected to dereference the pointer before
     882$    indexing the tuple header in the case that #result /= #tuple.
     883$ 3. the condition for not reallocating a new hash table in 'expand'
     884$    has been strengthened to account for the call to 'gethash', which
     885$    is a recursive routine and thus requires additional stack space.
     886$ 4. 'lpad(str, n)' and 'rpad(str, n)' return str rather than error if
     887$    #str > n.
     888
     889
     890$ 09/17/79     79259     s. freudenberger
     891$
     892$ 1. the interpreter cases for 'ok' and 'fail' have been corrected to
     893$    return 'true' and 'false', resp.
     894
     895
     896$ 09/13/79     79256     s. freudenberger
     897$
     898$ 1. 'from' emits a message when used on tuples, then calls 'frome'.
     899$    the code which used to handle tuples has been deleted.
     900$ 2. 'fromb' and 'frome' have been modified to copy their second
     901$    argument if it is shared.
     902$ 3. 'print2' has been modified to print 'true' and 'false' for the
     903$    corresponding boolean values.
     904$ 4. 'eof' has been modified to return true or false, as appropriate.
     905$ 5. logical file names are sized using 'filenamlen' ( defined in
     906$    cmnpl.sysmac)
     907$ 6. 'expand' has been modified to only expand the hash table if this
     908$    won't cause a garbage collection.
     909$ 7. 'arbs' has been modified to return a proper omega when its
     910$    argument is a nullset with correct cardinality fields.
     911
     912
     913$ 09/06/79     79250     s. freudenberger
     914$
     915$ 1. the deck 'macros' has been incorporated into the deck 'lib'.  this
     916$    has the advantage that we read only once trough 'cmnpl'.
     917$ 2. the 'getr' routine has been rewritten, using the newly provided
     918$    little 'getvsio' routine to directly read a variable length record
     919$    into a setl string.
     920
     921
     922$ 09/05/79     79248     s. freudenberger
     923$
     924$
     925$ this correction set installs setl 2.1
     926$
     927$
     928$  1. the interpreter has been updated to reflect the language
     929$     changes.
     930$  2. the set union routines 'union' and 'unset' were corrected to
     931$     set share bits of the second input's components when they were
     932$     included into the result.
     933$  3. 'unrset' was corrected to compute the cardinality of the result
     934$     properly.
     935$  4. the 'sofa' routine has been corrected so that is copies 'f' before
     936$     it modifies it.  the erroneous code worked properly in the unbased
     937$     case since it would always convert 'f' to a 'f_umap' before it
     938$     used it.
     939$  5. the sizing of 'nulllc' in 'lpad' and 'rpad' has been corrected.
     940$  6. 'sfix', 'sfloat', 'ceil', and 'floor' have been modified to
     941$     (1.) perform the necessary type checks
     942$     (2.) compute the correct result
     943$  7. several bugs have been fixed around the index compaction of
     944$     element base blocks.
     945$  8. a (suspected) bug has been fixed in 'getspace', when pointers
     946$     in environment blocks are updated.
     947$  9. 'top' and 'bot' have been replaced by 'ceil' and 'floor'.
     948$ 10. the routine 'interp' (finally) became an individual member (or
     949$     deck, for s66).  it is not part of member 'interp1' anymore.
     950$ 11. the library routines for the 'fromb' and 'frome' operaotrs
     951$     were added.
     952$ 12. the library routines for the 'len' and 'rlen' string primitives
     953$     were added.
     954$ 13. as a short cut, several new error messages have not been added to
     955$     the error routines.  this is considered a bug, and will be
     956$     corrected as time permits.
     957
     958
     959$ 07/25/79     79206     s. freudenberger
     960
     961$ 1. the interpreter case 'q2_nextus' has been modified so that the
     962$    share bit of the specifier retrieved is set.
     963$ 2. locate has been corrected so that 'loc_prev' is always set on
     964$    inequality in the search loop.
     965$ 3. augment has been corrected to check overflow of the ebindx-field
     966$    correctly.
     967$ 4. contract has been corrected to update the pointer of the last
     968$    element of the clash list of the new last hash header correctly.
     969
     970
     971$ 07/20/79     79201     s. freudenberger
     972
     973$ 1. the remaining code shared between the code generator and the
     974$    library has been moved into the common library.
     975$ 2. 'read_cntr' and 'getb_cntr' are initialized properly.
     976$ 3. the s32 starts the interpreter via an environment routine.
     977$ 4. error messages on the s10 are written on the device 'tty:' rather
     978$    than the file 'tty'.
     979$ 5. error messages on the s32 are written on 'sys$error' by default.
     980$ 6. set braces are given as octal constants for the s10.
     981$ 7. the interpreter's 'q2_witht' and 'q2_withut' cases have been
     982$    corrected to handle omega properly.
     983$ 8. the interpreter's 'q2_inext' case has been corrected to account
     984$    for proper dereferencing of 's'.
     985$ 9. the comparison routines 'eqprim', 'lt', and 'ge' have been
     986$    modified to compare reals correctly.
     987$ 10. -real .div real- has been prohibited, and yields an error message.
     988$ 11. 'mult' now performs the correct copy action after swapping the
     989$     input sets and before calling 'intersect'.
     990$ 12. 'lessf' has been modified to attempt to convert a set to a map.
     991$     (it used to convert a set to a set....)
     992$ 13. 'of' and 'ofa' have been modified to check whether the conversion
     993$     of a set to a map was successful.
     994$ 14. 'nextd' now jumps on the otype_ rather than the type_.
     995$ 15. 'getr' has been modified to circumvent little fr2.3.109
     996$ 16. some small errors have been corrected in the binary i/o
     997$ 17. 'gethash' has been corrected so that firstly, the hash of a null
     998$     string is defined, and secondly, the hash of a tuple is only
     999$     computed up to the nelt of the tuple.
    1000$ 18. the garbage collector now expands the heap only in junks of
    1001$     ten percent (as opposed to 25 percent).  it also prints a
    1002$     'gtrace' message if and when it expands the heap.
    1003$ 19. several errors have been corrected in the conversion routines.
    1004$     all of them were due to pointers being updated, but not replaced
    1005$ in their respective specifiers or recursive counterparts.
    1006
    1007
    1008$ 05/18/79     79138     s. freudenberger and d. shields
    1009
    1010$ 1. the binary read has been re-designed, and the appropriate changes
    1011$    made.
    1012$ 2. two new conditional assembly options have been added
    1013$    2.1 'defenv_envmhl' controls heap management
    1014$    2.2 'defenv_envrsi' defines how the interpreter is restarted after
    1015$        a garbage collection.
    1016$ 3. a number of garbage collector routines have been renamed
    1017$        garbcolns ---> nsgarbcol
    1018$        garbadj -----> gadjust
    1019$        garbcomp ----> gcompact
    1020$        gbcomp1 -----> gbcmp1
    1021$        gbcomp2 -----> gbcmp2
    1022$        ...            ...
    1023$        gbcomp5 -----> gbcmp5
    1024$ 4. the instruction format for the dec 10 has been revised.
    1025$ 5. 'bldsds' has been modified so that all unused bits are zero.
    1026
    1027
    1028$ 04/27/79     79117     s. freudenberger
    1029
    1030$ 1. the heap is written by the code generator in slices, skipping
    1031$    the two undefined blocks between the constant and the dynamic
    1032$    part of the heap, and between the heap and the stack.
    1033$ 2. since the form table is shared between the semantic pass, code
    1034$    generator, and the library, it has been placed into a common
    1035$    library, and is included as an inclusion member.
    1036$ 3. 'str < str' and 'str >= str' check their second arguments for
    1037$    omega.
    1038$ 4. the default set bracket character for s10 on output has been
    1039$    changed to set braces.
    1040$ 5. the heap has been placed into a nameset 'nsheap', which also
    1041$    contains a variable 'cur_heap_dims' giving the current actual
    1042$    available size of the heap.  (well, it eventually will... for
    1043$    this version it is just an undefined variable which is never
    1044$    used.)
    1045$    n.b. for s66, a macro maps 'nsheap' into 'blank', fortran blank
    1046$         common.
    1047$ 6. 'getspace' has been modified as to claim as much space as
    1048$    possible, even if it is less than requested.  it now only aborts
    1049$    if the abort flag is set.
    1050$    this change means that, if your current run field length limit
    1051$    would permit you to acquire 1000 more words of memory, and your
    1052$    job requests, let's say 1500 more words, your job will get the
    1053$    1000 words.  up to now, your job would have aborted with
    1054$    'insufficient main storage'.
    1055$ 7. the standard read routines have been modified so that they
    1056$    resume execution properly after they have been interrupted by a
    1057$    garbage collection.
    1058$ 8. 'getem' and 'setem' have been made functions rather than
    1059$    subroutines, since that is the way the interpreter calls them.
    1060
    1061
    1062$ 04/12/79     79102     s. freudenberger and d. shields
    1063
    1064$ 1. the binary read has been corrected so that it restarts correctly
    1065$    after a garbage collection.
    1066$ 2. an option has been added to echo all error messages to the
    1067$    file specified by the -term- control card parameter.
    1068$ 3. the heap size can be specified in kilowords:  every h-value less
    1069$    than 1000 is assumed to specify a heap size in kilowords.
    1070$ 4. for the s32, curley brackets will print as curley brackets, unless
    1071$    specified differently.
    1072
    1073
    1074$ 04/10/79     79100     s. freudenberger
    1075
    1076$ 1. some of the form table fields for the 6600 have been
    1077$    redefined so that the -ft_pos- field does not cross a
    1078$    word boundery.
    1079$ 2. the nameset used by the interpreter has been renamed to -nsinterp-.
    1080$ 3. the interpreter cases for -q2_nextt- and -q2_nextut- have been
    1081$    corrected so that the iteration block will be executed for the
    1082$    last component of the tuple.
    1083$ 4. tuple retrievels have been corrected so that omega is returned
    1084$    if the index exceeds the tuple-s nelt.
    1085$ 5. the check for omega component in -intersect- has been corrected.
    1086$ 6. first corrections have been made to the -getb- routine to handle
    1087$    interupts by the garbage collector correctly.  at this point,
    1088$    some problems remain.
    1089
    1090
    1091$ 04/03/79     79093     s. freudenberger and d. shields
    1092
    1093$ 1. the form predicates have been implemented in a different way, so
    1094$    that machines with a wordsize less than 35 bits will get the
    1095$    correct results.  (the new implementation also should be more
    1096$    efficient)
    1097$ 2. when iterating over a map, -nexts- does not update the domain
    1098$    element of both the iterator and the value until it has checked
    1099$    whether an range iteration step is necessary.  this change is
    1100$    the result of (nyu-cims) bug 24, which showed that elements
    1101$    were skipped if -nexts- was interupted by a garbage collection.
    1102$ 3. -getb- only looks up the little file identifier (via call to
    1103$    -file_id-) when it is entered for the first time.  if it is
    1104$    called after a garbage collection, it merely continues at the
    1105$    point at which it was interupted.
    1106$ 4. the same change (3. above) has been made to -reada-.
    1107
    1108
    1109$ 03/27/79     79086     s. freudenberger
    1110
    1111$ 1. the macro for -hl_code- has been corrected in the s10, s32,
    1112$    and s37 field definitions.
    1113$ 2. -inextd- has been corrected to attempt to convert a set to
    1114$    a map before the start of the iteration.
    1115$ 3. the test for q2_gonins has been corrected.
    1116$ 4. -of- and -sof- return error values if the conversion from
    1117$    set to map fails.
    1118$ 5. q2_subst and q2_ssubst don-t increment the code pointer until
    1119$    they return from the library, so that the interpreter is re-
    1120$    started correctly after a garbage collection.
    1121$ 6. the predicates on forms have been reviewed and corrected where
    1122$    necessary.
    1123$ 7. the semantics of substrings has been changed:
    1124$         s(i...j) := y <===> s := s(...i-1) + y + s(j+1...)
    1125$         y := s(i...j) <===> y := +/[ a(k) : k := i...j ]
    1126$ 8. -rset2- has been corrected to set is_multi_ bits correctly.
    1127$ 9. -getf-, -putf-, and -spec- have been corrected.
    1128$ 10. various namesets have been renamed:
    1129$          formtab ---> nsformtab
    1130$          sname -----> nssname
    1131$          std -------> nsstd
    1132$ 11. the definitions of -om_int- and -om_real- have been
    1133$     reviewed.
    1134
    1135
    1136$ 03/15/79     79074     s. freudenberger
    1137
    1138$ 1. mixed mode arithmetic has been abandoned.
    1139$ 2. -specr- has been corrected to handle negative integers
    1140$    correctly.
    1141$ 3. the minimum gap for the garbage collector had to be increased,
    1142$    and -nullp- has been corrected so that is does use only the
    1143$    space needed for the recursion stack;  long integers and reals
    1144$    are not compared via a call to -fval-, but rather compared in-
    1145$    line.
    1146$ 4. -convsm- has been modified to de-reference element types before
    1147$    it uses them.
    1148$ 5. -snap- has been made totally controlled by the -snap- control
    1149$    card parameter.
    1150
    1151
    1152$ 03/05/79     79065     s. freudenberger
    1153
    1154$ 1. after base index compaction during garbage collection, remote
    1155$    objects now are updated correctly.
    1156$ 2. the call of snap during a debug rdmp has been made dependent of the
    1157$    setting of the snap control card parameter.
    1158$ 3. snap has been changed to print the q2 instruction rather then the
    1159$    index of the q2 instruction.
    1160
    1161
    1162$ 02/12/79     79043     a. grand and s. freudenberger
    1163
    1164$ 1. the interpreter case q2_ge now tests the types of the
    1165$    second and third argument before calling the library.
    1166$ 2. the index of the last character of the result subject string
    1167$    of -rmatch- now is a setl specifier.
    1168$3 3. on end-of-file, newliner now returns an eof character rather than
    1169$    the first character of the last line.
    1170
    1171
    1172$ 01/30/79     79030     a. grand and s. freudenberger
    1173
    1174$ 1. we fixed the -npow- and -initnpow- routines so that the -nelt-
    1175$    macro uses the correct field.
    1176$ 2. we changed the value of om_int for s37 and s32 to the maximum
    1177$    negative number.
    1178$ 3. we changed the name of the q2 file for the s32 to -q2.tmp-.
    1179$ 4. throughout the equality routines, we have replaced the parameter
    1180$    names -a1- and -a2- by -arg1- and -arg2-, resp.
    1181$ 5. we corrected various field definition which were found erroneous
    1182$     during our work on the vax.
    1183$ 6. we changed the name of the garbage collector nameset to
    1184$    -garbcolns-.
    1185$ 7. we corrected the print routine to print reals in e-format.
    1186$ 8. we fixed the read routine to accept reals in e-format.
    1187
    1188
    1189$ 12-27-78     78361     a. grand and d. shields
    1190
    1191$ this mod installs machine dependent code for the ibm-370, dec-10,
    1192$ and vax. it also fixes a bug in tuple iterators.
    1193
    1194
    1195
    1196$ 12-8-78     78342     a. grand
    1197
    1198$ 1.  the measurement package has been cleaned up. there is now
    1199$     a conditional assembly option 'sti' in which the time spent
    1200$     in the interpreter is not counted in the total library time.
    1201$     this gives us a much better picture of the ratio of library
    1202$     to nubbin time.
    1203$     we have added a feature which prints the number of times each
    1204$     q2 opcode is executed. we also print the total execution time
    1205$     and the percentage of time spent in nubbins.
    1206$ 2.  we now print a dayfile message giving the time and date of the
    1207$     last library change.
    1208$ 3.  we fixed bugs in the < and >= tests so that they generate an error
    1209$     message when the user tries to compare a real with omega.
    1210$ 4.  the om_image macro now works through formtab rather than calling
    1211$     fval.
    1212$ 5.  double angled brackets are now read correctly in << a, 1, 2 >>.
    1213$ 6.  we have added a control card option snap=1/1 which prints a snap
    1214$     after each error message.
    1215$ 7.  we have added a control card parameter assert=1/2 which controls
    1216$     the assert statement. its values are:
    1217$     0: ignore all assertions
    1218$     1: print error message for assertions which fail
    1219$     2: also print message for assertions which work
    1220$ 8.  we fixed a bug in the declarations for 'opname2'. this is
    1221$     one of the arrays which contains the names of q2 opcodes.
    1222$ 9.  we moved some macros out of the member 'q2_macs' so that the
    1223$     little compiler doesn't overflow when we compile the code
    1224$     generator.
    1225$ 10. we fixed a variety of bugs in the union, intersection and set
    1226$     difference routines. these include miscellaneous coding bugs,
    1227$     and incorrect treatment of smaps which become multivalued.
    1228$ 11. we fixed several bugs in the equality routine invloving based
    1229$     sets and maps.
    1230$ 12. we fixed a bug in copying sets.
    1231$ 13. we changed 'match' and 'rmatch' to have the correct semantics.
    1232$ 14. the foriegn i/o, spec, and unspec routines now access packed
    1233$     tuples correctly. psets are also represented as packed tuple(1...1
    1234
    1235
    1236$ 11-15-78     78319     a. grand and s. freudenberger
    1237
    1238$ 1. it fixes 'lt' and 'ge' to handle mixed long and short
    1239$    integers correctly.
    1240$ 2. it fixes the q2 dump to print the q2_lev operator properly.
    1241$ 3. it fixes the eof operator. this includes both changes to 'eof'
    1242$    itself and changes to the buffers used by the 'read' routines.
    1243
    1244
    1245
    1246
       1 .=member stlini
       2      subr stlini;
       3$
       4$ this is the root module for the setl run time system.  it contains
       5$ the table declarations which define q2, plus some initialisation
       6$ code.
       7$
       8      +*  prog_level =  $ program level(julian date of last fix)
smff   9      'lib(85007) '
      10          **
      11
      12
      13 .=include cndasm             $ conditional assembly
      14 .=include sysmac             $ machine parameters
      15
      16 .=include formtab            $ form table
      17
      18 .=include q2flds             $ q2 fields to access heap
      19
      20 .=include q2opcd             $ q2 opcodese q2opcd
      21 .=include q2macs             $ (general) q2 macros
      22 .=include q2vars             $ global variables
      23
      24 .=include binio              $ definitions for setl binary i/o
mjsa  19 .=include lipkg              $ long integer arithmetic package
      25 .=include measpkg            $ measurement package
      26 .=include strpkg             $ string primitives
      27 .=include mhfpkg             $ mapped heap file package
      28
      29
      30 $ define codes for is_xxx operators
      31
      32 .=zzyorg z
      33
      34      defc(ist_int)           $ integer
      35      defc(ist_rea)           $ real
      36      defc(ist_str)           $ string
      37      defc(ist_boo)           $ boolean
      38      defc(ist_ato)           $ atom
      39      defc(ist_pri)           $ primitive
      40      defc(ist_tup)           $ tuple
      41      defc(ist_set)           $ set
      42      defc(ist_map)           $ map
      43
      44      +* ist_max = ist_map **  $ maximum ist_ value
      45
      46
      47
      48
      49$ codes for real elementary functions
      50$ ----- --- ---- ---------- ---------
      51
      52$ several of the real elementary functions are implemented in a
      53$ single routine.  the following codes are used to distinguish the
      54$ various functions.
      55
      56 .=zzyorg z
      57
      58      defc(relf_acos)         $ acos
      59      defc(relf_asin)         $ asin
      60      defc(relf_atan)         $ atan
      61      defc(relf_cos)          $ cos
      62      defc(relf_exp)          $ exp
      63      defc(relf_log)          $ log
      64      defc(relf_sin)          $ sin
      65      defc(relf_sqrt)         $ sqrt
      66      defc(relf_tan)          $ tan
      67      defc(relf_tanh)         $ tanh
      68
      69      +*  relf_min  =  relf_acos  **  $ first
      70      +*  relf_max  =  relf_tanh  **  $ last
      71
      72
      73$ the reserved files for the library are:
      74
      75 .=zzyorg z
      76
      77      defc(in_file)           $ input file
      78      defc(out_file)          $ output file
      79      defc(q2_file)           $ q2 file
      80 .+hf defc(q2e_file)          $ q2 environment file
      81$
      82$ nb. file 3, the q2_file, is 'private' to the library in the sense
      83$ that setl programs will never use this file identifier.
      84$ file 4, the q2e_file, is not private, and must therefore be used
      85$ in a manner which will avoid conflicts with the executing setl
      86$ program.
      87$
      88
      89
      90
      91$ modes for assert statement
      92
      93 .=zzyorg z
      94
      95      defc0(assert_off)       $ ignore assertions
      96      defc0(assert_part)      $ print message on failure
      97      defc0(assert_full)      $ print message on success/failure
      98
      99
     100
     101
     102$ begin execution by initializing all debugging aids.
     103 .+tr monitor noentry, nostores;
     104
     105
     106      nameset nsio;           $ globals used for i/o
     107
     108          size buffer(buffer_size);
     109          dims buffer(file_max);
     110
     111          data buffer = blank_buffer(file_max);
     112
     113          size cursor(ps);    $ array of cursors for above
     114          dims cursor(file_max);
     115
     116          data cursor = 1(file_max);  $ to force new lines
     117
     118          size rd_char(cs);   $ current character being read
     119
     120          size catab(catab_sz);   $ character attribute table
     121          dims catab(cs_sz);
     122 .-s10.
     123$ catab should by default be initialized in data statement.
     124$ this not possible for s10 due to little compiler restriction
     125$ in length of data statement that shows up here in that 512 distinct
     126$ values cannot be initialized. as only s10 will probably have such
     127$ a large character set size, we use data statement 'by default' and
     128$ use initialization by code for s10 only.
     129
     130          data catab = 0(cs_sz);
     131 ..s10
     132
     133
     134          size last_id(ps);   $ number of last input file accessed
     135          data last_id = 0;
     136
     137$ the following variables give the strings used to represent
     138$ square brackets and curley brackets in the print routine. these
     139$ are selected by control card options.
     140
     141          size sb_string(.sds. 2);  $ string for set braces
     142          size lsb_char(chsiz);     $ left set brace
     143          size rsb_char(chsiz);     $ right set brace
     144
     145          size tb_string(.sds. 2);  $ string for tuple brackets
     146          size ltb_char(chsiz);     $ left tuple bracket
     147          size rtb_char(chsiz);     $ right tuple bracket
     148
     149$ -setl_digit- is a zero origined array mapping 0-9 into the
     150$ corresponding integers.
     151          defzero(setl_digit, a_setl_digit);
     152          size a_setl_digit(hs);
     153          dims a_setl_digit(10);
     154
     155$ -rdigit- maps 0-9 into 0.0 to 9.0
     156          defzero(rdigit, a_rdigit);
     157          real a_rdigit;
     158          dims a_rdigit(10);
     159
     160$ we will need some loop indices, etc. to initialize the above. we
     161$ give them unlikely names.
     162          size jjj(ps);       $ loop index
     163          size ccc(ps);       $ character code
     164
     165 .+mc     size ctsc(cs);      $ converts character to secondary case
     166      end nameset nsio;
     167
     168
     169      nameset nsread;         $ static variables for coded read
     170
     171          size read_file(ps), $ little file identifier
     172               read_indx(ps); $ index of current argument in arglist
     173
     174          size read_case(ps); $ code read_xxxx
     175          data read_case = read_init;
     176
     177          size read_key(hs);  $ key to distinct sets and tuples
     178
     179          size read_cntr(hs); $ number of components read so far
     180          data read_cntr = 0;
     181
     182          size read_flag(1);  $ flags reading string
     183          data read_flag = no;
     184
     185          size read_len(ps),  $ length of string
     186               read_ss(ssz);  $ string specifier for result
     187
     188          size read_t1(ps),   $ stack pointer at initial entry
     189               read_t2(ps);   $ local reference stack pointer
     190
     191      end nameset nsread;
     192
     193
     194      nameset nsgetb;         $ static variables for binary read
     195
     196          size getb_file(ps), $ little file identifier
     197               getb_indx(ps); $ index of current argument in arg list
     198
     199          size getb_case(ps); $ code getb_xxxx
     200          data getb_case = getb_init;
     201
     202          size getb_spec(hs), $ current specifier
     203               getb_word(hs), $ last word read
     204               getb_ss(ssz);  $ string specifier for bt_string
     205
     206          size getb_cntr(hs); $ number of components read so far
     207          data getb_cntr = 0;
     208
     209          size getb_typ(ps),  $ type of header block
     210               getb_val(ps),  $ value of header block
     211               getb_ptr(ps);  $ pointer to heap block
     212
     213          size getb_t1(ps),   $ stack pointer at initial entry
     214               getb_t2(ps);   $ local reference stack pointer
     215
     216      end nameset nsgetb;
     217
     218
     219      nameset nsintf;         $ nameset for fortran interface
     220
     221          size intf_extadr(ws);   $ address of external entry vector
     222          size intf_extlen(ws);   $ its length
     223          data intf_extadr = 0;
     224          data intf_extlen = 0;
     225
     226          size intf_case(ps); $ code intf_xxxx
     227          data intf_case = intf_init;
     228
     229          size intf_parm(ps); $ pointer to start of parameter list
     230          size intf_t2(ps);   $ pointer to start of auxiliary storage
     231          size intf_na(ps);   $ length of external parameter list
     232          size intf_indx(hs); $ index of current argument
     233          size intf_argp(hs); $ index of external parameter
     234          size intf_spec(hs); $ specifier
     235
     236      end nameset nsintf;
     237
     238 .+s32u.
     239      nameset nsvadv;
     240         size vadvise(hs);  $ switch for vadvise
     241      end nameset;
     242 ..s32u
sunb  21 .+s68.
sunb  22      nameset nsvadv;
sunb  23         size vadvise(hs);  $ switch for vadvise
sunb  24      end nameset;
sunb  25 ..s68
     243
     244
     245$ initialize catab
suna  16 .+r36.
     247$ initialize catab for s10 (see comments before near data statement
     248$ for catab to see why this must be done).
     249      do jjj=1 to cs_sz; catab(jjj) = 0; end do;
suna  17 ..r36
     257
     258
     259$ begin by setting all lexical classes to the error case, then reset
     260$ the valid ones.
     261      do jjj = 0 to cs_sz-1;
     262          lexclass(jjj) = read_error;
     263      end do;
     264
     265$ initialize digits
     266      do jjj = 1 to 10;
     267          ccc = .ch. jjj, '0123456789';
     268
     269          alphameric(ccc) = yes;
     270          numeric(ccc)    = yes;
     271          lexclass(ccc)   = read_num;
     272          dig_val(ccc)    = jjj-1;
     273      end do;
     274
     275      do jjj = 1 to 26;
     276          ccc = .ch. jjj, 'abcdefghijklmnopqrstuvwxyz';
     277
     278          alphameric(ccc) = yes;
     279          lexclass(ccc)   = read_name;
     280 .+mc.
     281          ccc = ctsc(ccc);    $ if secondary case available
     282          alphameric(ccc) = yes;
     283          lexclass(ccc)   = read_name;
     284 ..mc
     285      end do;
     286
     287      alphameric(1r^) = yes;
     288
     289$ initialize classes of special characters
     290      lexclass(1r-) = read_num;
     291      lexclass(1r#) = read_bool;
     292      lexclass(1r+) = read_num;
     293      lexclass(1r ) = read_blank;
     294      lexclass(1r') = read_str;
     295
     296 .+s10    lexclass(123) = read_set1;   $ left set brace
     297 .+s20    lexclass(123) = read_set1;   $ left set brace
     298 .+s32    lexclass(123) = read_set1;   $ left set brace
     299 .+s37    lexclass(192) = read_set1;   $ left set brace
     300 .+s47    lexclass(123) = read_set1;   $ left set brace
     301 .+s66    lexclass(1r@) = read_set1;   $ at sign
suna  18 .+s68    lexclass(123) = read_set1;   $ left set brace
     302
     303      lexclass(1r<) = read_set2;
     304      lexclass(1r[) = read_tup1;
     305      lexclass(1r() = read_tup2;
     306
     307 .+s10    lexclass(125) = read_set3;   $ right set brace
     308 .+s20    lexclass(125) = read_set3;   $ right set brace
     309 .+s32    lexclass(125) = read_set3;   $ right set brace
     310 .+s37    lexclass(208) = read_set3;   $ right set brace
     311 .+s47    lexclass(125) = read_set3;   $ right set brace
     312 .+s66    lexclass(1r\) = read_set3;   $ reverse slant
suna  19 .+s68    lexclass(125) = read_set3;   $ right set brace
     313
     314      lexclass(1r>) = read_set4;
     315      lexclass(1r]) = read_tup3;
     316      lexclass(1r)) = read_tup3;
     317      lexclass(1r/) = read_tup4;
     318      lexclass(1r*) = read_om;
     319      lexclass(eof_char) = read_eof;
     320
     321
     322$ initialize setl_digit and rdigit
     323
     324      setl_digit(0) = zero;
     325
     326      do jjj = 1 to 9;
     327          setl_digit(jjj) = setl_digit(jjj-1);
     328          add1(setl_digit(jjj));
     329      end do;
     330
     331      data rdigit(0) = 0.0, 1.0, 2.0, 3.0, 4.0, 5.0, 6.0, 7.0, 8.0, 9.0;
     332
     333
     334      nameset nsperf;
     335
     336          size lcs_flag(1);   $ list statistics
     337
     338          size stm_exe(ws);   $ statements executed
     339          data stm_exe = 0;
     340
     341          size grb_tim(ws);   $ garbage collection time
     342          data grb_tim = 0;
     343
     344          size grb_tot(ws);   $ number of garbage collections
     345          data grb_tot = 0;
     346
     347          size grb_rec(ws);   $ number of words recovered
     348          data grb_rec = 0;
     349
     350          size init_heap_len(ws);     $ initial heap length
     351          data init_heap_len = 0;
     352
     353      end nameset nsperf;
     354
     355
     356      end subr stlini;
       1 .=member stllib
       2      prog stllib;
       3$
       4$ this is the default setl interpreter, for historical reasons known
       5$ as stllib (or lib).  it merely initialises the setl run time system
       6$ by calling stlini, then initialises the environment by calling
       7$ libini, an then starts interpreting.  since this is a little main
       8$ program, this routine implicitly call ltlini to initialise the
       9$ little run time system.
      10$
      11      call stlini;            $ initialise the setl library
      12
      13      call libini;            $ read the control card parameters and
      14                              $ the heap
      15
      16      $ call the interpreter
      17 .+s10    call interp;
      18 .+s20    call interp;
      19 .+s32    while 1; call envssi; end while;
      20 .+s37    call interp;
      21 .+s47    call interp;
      22 .+s66    call interp;
suna  20 .+s68    call envssi;
      23
      24$ nb. we never return from the interpreter;  instead, execution is
      25$ terminated when we reach a q2_stop instruction.
      26
      27
      28      end prog stllib;
       1 .=member stlint
       2
       3
       4 .+defenv_envfor.
       5
       6
       7      subr stlint(extvec, extlen);
       8
       9
      10      size extvec(ws);        $ external entry vector
      11      size extlen(ws);        $ length of external entry vector
      12
      13      size pimadr(ws);        $ returns absolute memory address
      14
      15      access nsintf;
      16
      17
      18      intf_extadr = pimadr(extvec);
      19      intf_extlen = extlen;
      20
      21$
      22$ this is the fortran callable setl interpreter.  it is identical to
      23$ the default interpreter as far as the interpretation of the setl
      24$ code is concerned, but in addition contains the code to initialise
      25$ the little run time system and with set up communication to fortran.
      26$
      27      call ltlini(0);         $ initialise the little library
      28
      29      call stlini;            $ initialise the setl library
      30
      31      call libini;            $ read the control card parameters and
      32                              $ the heap
      33
      34      $ call the interpreter
      35 .+s10    call interp;
      36 .+s20    call interp;
      37 .+s32    while 1; call envssi; end while;
      38 .+s37    call interp;
      39 .+s47    while 1; call envssi; end while;;
      40 .+s66    call interp;
suna  21 .+s68    call envssi;
      41
      42$ nb. we never return from the interpreter;  instead, execution is
      43$ terminated when we reach a q2_stop instruction.
      44
      45
      46      end subr stlint;
      47
      48
      49 ..defenv_envfor
      50
      51
      52
      53 .+tr trace entry;
      54
      55 .+part1.
      56
      57
       1 .=member libini
       2      subr libini;
       3
       4$ this routine is called to initialize the environment. it performs
       5$ three types of initialization:
       6
       7$ 1. initialize the listing file
       8
       9$ 2. read control card parameters
      10
      11$ 3. read the environment from the q2 file and initialize all
      12$    related variables.
      13
      14
      15      size q2_title(.sds. filenamlen);    $ q2 file
      16      size term_title(.sds. filenamlen);  $ terminal file
      17
      18      size ret(ws);           $ return value from namesio
      19      size ih_lim(ps);        $ initial value of h_lim
smfb  61      size mh_lim(ps);        $ maximum value for h_lim
      20 .+tr size e_flag(1);         $ trace entry flag
      21 .+tr size s_flag(1);         $ trace stores flag
      22      size d_flag(1);         $ flags initial dump request
      23      size t_flag(1);         $ on if standard titling desired
      24      size len(ps);           $ length of bracket string
      25      size cur_dim(ws);       $ current heap dimension
      26      size max_dim(ws);       $ maximum heap dimension
      27      size max_nf(ps);        $ maximum number of open user files
      28      size timestr(.sds. 30); $ current time
      29      size termh_flag(1);     $ print phase heading on terminal
      30 .+mc.
      31 $ socase is case of string results, such as produced by 'type'
      32 $ operator:
      33 $      0       no change (default)
      34 $      1       lower case
      35 $      2       upper case
      36 $
      37      size socase(ps);        $ select output case
      38 ..mc
      39      size lcp_flag(1);       $ list control card parameters
      40
      41      $ the following two variables are needed to read the form table
      42      $ in conjunction with the hf option.  the form table should
      43      $ eventually be included into the heap, at which point these two
      44      $ variables can be deleted.
      45      size first(ps);         $ first entry of table
      46      size last(ps);          $ last entry of table
      47
      48
      49      +* getapp_len  =
      50 .+s10    128
      51 .+s20    128
      52 .+s32    240
      53 .+s37    128
      54 .+s47    240
      55 .+s66    128
suna  22 .+s68    240
      56          **
      57
      58      size app(.sds. getapp_len);
      59      call getapp(app, getapp_len); $ get full parameter string.
      60
      61$ read control card parameters
      62 .+s32u.
      63      call getipp(vadvise,'vadvise=0/1');
      64 ..s32u
sunb  26 .+s68.
sunb  27      call getipp(vadvise, 'vadvise=1/1');
sunb  28 ..s68
      65
      66 .+s10    call getspp(q2_title,   'q2=q2/');           $ q2 file
      67 .+s20    call getspp(q2_title,   'q2=q2/');           $ q2 file
      68 .+s32    call getspp(q2_title,   'q2=q2.tmp/q2.tmp'); $ q2 file
      69 .+s37    call getspp(q2_title,   'q2=q2/');           $ q2 file
      70 .+s47    call getspp(q2_title,   'q2=q2/');           $ q2 file
      71 .+s66    call getspp(q2_title,   'q2=q2/');           $ q2 file
suna  23 .+s68    call getspp(q2_title,   'q2=setl.q2/');      $ q2 file
      72
      73      term_title='';
      74      call namesio(max_no_files,ret,term_title,filenamlen); $ error file
      75      if (ret > 1) term_title = '';    $ namesio unavailable or no term
      76
      77
      78 .+tr call getipp(e_flag,    'entry=0/1');   $ trace entry flag
      79 .+tr call getipp(s_flag,    'stores=0/1');  $ trace stores flag
      80      call getipp(d_flag,    'idump=0/1');   $ initial dump
      81      call getipp(t_flag,    'title=0/1');   $ default titling
      82      call getipp(assert_mode,  'assert=1/2');  $ assert mode
      83      call getipp(debug_flag,   'debug=0/1');   $ run with debugger on
      84      call getipp(trace_stmts,  'strace=0/1');  $ trace statements no.s
      85      call getipp(trace_calls,  'ctrace=0/1');  $ trace procedure calls
      86      call getipp(snap_flag,    'snap=0/1');    $ give snaps for errors
      87      call getipp(termh_flag,   'termh=0/1');   $ print phase header
      88      call getipp(lcp_flag,  'lcp=0/1');     $ list control parameter
      89      call getipp(lcs_flag,  'lcs=0/1');     $ list control statistics
      90
      91 .+gt call getipp(gtrace,    'gtrace=0/1');
      92 .+gt call getipp(gdump,     'gdump=0/1');
      93
      94      $ if we trace statements or calls globally, we automatically
      95      $ enable the trace package
      96      if (trace_stmts ! trace_calls) debug_flag = yes;
      97$
      98$ we assume a minimum heap size of 1024 words, and assume that if
      99$ ih_lim is less than this value, it specifies the heap size in
     100$ kilo-words.  note that the algorithm used here is identical to
     101$ the algorithm used in cod.
     102$
     103      call getipp(ih_lim,    'h=0/0');       $ initial heap length
     104      if (0 < ih_lim & ih_lim < 1024) ih_lim = ih_lim * 1024;
     105      if (ih_lim = 0) ih_lim = default_h;
smfb  62
smfb  63      call getipp(mh_lim,    'max_heap=0/0');   $ maximum heap length
smfb  64      if (0 < mh_lim & mh_lim < 1024) mh_lim = mh_lim * 1024;
     106
     107      call getipp(err_limit, 'rel=0/0');    $ runtime error limit
     108
asca  13 .+ascebc.
asca  14      call getipp(ascebc_flag,  'ascii=0/1');  $ ebcdic-to-ascii conv
asca  15      if (ascebc_flag) call aeinit;  $ initialise conversion tables
asca  16 ..ascebc
     109
     110      call getspp(tb_string,  'tb=[]/()');   $ tuple brackets
     111
     112
     113 .+s10.
     114          $ use ascii set braces as default set delimiter
     115          size sb_parm_string(.sds. 8);
     116          data sb_parm_string = 'sb=  /
';
     117          .ch. 4, sb_parm_string = 3b'173';
     118          .ch. 5, sb_parm_string = 3b'175';
     119          call getspp(sb_string, sb_parm_string);   $ set braces
     120 ..s10
     121
     122 .+s20.
     123          $ use ascii set braces as default set delimiter
     124          size sb_parm_string(.sds. 8);
     125          data sb_parm_string = 'sb=  /
';
     126          .ch. 4, sb_parm_string = 3b'173';
     127          .ch. 5, sb_parm_string = 3b'175';
     128          call getspp(sb_string, sb_parm_string);   $ set braces
     129 ..s20
     130
     131
     132 .+s32.
     133          size sb_parm_string(.sds. 8);
     134          data sb_parm_string = 'sb=  /
';
     135          .ch. 4, sb_parm_string = 4b'7b';
     136          .ch. 5, sb_parm_string = 4b'7d';
     137          call getspp(sb_string, sb_parm_string);   $ set braces
     138 ..s32
     139
     140 .+s37    call getspp(sb_string, 'sb=
/
');   $ set braces
     141 .+s47.
     142          size sb_parm_string(.sds. 8);
     143          data sb_parm_string = 'sb=  /
';
     144          .ch. 4, sb_parm_string = 4b'7b';
     145          .ch. 5, sb_parm_string = 4b'7d';
     146          call getspp(sb_string, sb_parm_string);   $ set braces
     147 ..s47
     148
     149 .+s66    call getspp(sb_string, 'sb=
/
');   $ set braces
suna  24
suna  25 .+s68.
suna  26          size sb_parm_string(.sds. 8);
suna  27          data sb_parm_string = 'sb=  /
';
suna  28          .ch. 4, sb_parm_string = 4b'7b';
suna  29          .ch. 5, sb_parm_string = 4b'7d';
suna  30          call getspp(sb_string, sb_parm_string);
suna  31 ..s68
     150
     151
     152      lsb_char = .ch. 1, sb_string;   rsb_char = .ch. 2, sb_string;
     153      ltb_char = .ch. 1, tb_string;   rtb_char = .ch. 2, tb_string;
     154
     155
     156$ turn on trace code if requested
     157 .+tr if (e_flag) monitor entry,  limit = 10000;
     158 .+tr if (s_flag) monitor stores, limit = 10000;
     159$
     160$ set up initial title if desired
     161$
     162      if t_flag then
     163          call stltitle(yes, 'cims.setl.' .cc. prog_level);
     164      end if;
     165
     166      if termh_flag then
     167          $ the following line is printed on the terminal file only
     168          call contlpr(26, no);   call contlpr(27, yes);
     169          call lstime(timestr);   $ get current time
     170          put, '  start cims.setl.', prog_level: timestr, a, skip;
     171          call contlpr(26, yes);  call contlpr(27, no);
     172      end if;
     173
     174      if lcp_flag then
     175          if (.len. app) then $ if parameters specified.
     176              put: app, a, skip(2);
     177          end if;
     178      end if;
     179
     180
     181 .+mhl_dynamic.                $ dynamic heap management
     182$
     183$ initially allocate a zero-length heap to set up address registers.
     184$
     185 .+s32v.  $ must allocate room for buffers in vms
     186      $ first find out how many files the user intends to open:
     187      call getipp(max_nf,       'nof=5/5');    $ number of open files
     188 ..s32v
     189
     190      $ then inquire how many words can be allocated:
     191      call envmhl(1, cur_dim, max_dim);
     192
     193      $ then determine what size heap to allocate:  this is the minimum
     194      $ of the space available minus buffer space for i/o routines, and
smfb  65      $ the initial heap size mh_lim (the h control card parameter).
     196      cur_dim = 0;
     197 .+s32v.
     198      max_dim = max_dim - (max_nf*220*512/4);
     199 ..s32v
     200      if (max_dim <= 0) call err_fatal(41);
smfb  66      if (0 < mh_lim & mh_lim < max_dim) max_dim = mh_lim;
     202
     203      $ allocate a zero-length heap which can be expanded to max_dim.
     204      call envmhl(2, cur_dim, max_dim);
     205 ..mhl_dynamic
     206
     207
     208 .-hf.                        $ standard system: read q2 file
     209$
     210$ open the q2 file, check its format, and read it
     211$
     212      file q2_file access = read, title = q2_title;
     213
     214 .+s66    rewind q2_file;
     215
     216      call chkq2f(q2_file, q2_checkw, oldest_q2, newest_q2);
     217      call rdheap(q2_file);
     218
     219      file q2_file access = release;
     220
     221
     222 .+hf.                        $ heap file mapped to paging file
     223 .+s32.                       $   -  for the vax under vms
     224
     225      call getspp(q2h_title,    'q2h=q2h/');    $ q2 h file
     226      call getspp(q2e_title,    'q2e=q2e/');    $ q2 e file
     227      call getipp(q2_init_type, 'q2init=0/1');  $ initialisation
     228      call getipp(hf_trace,     'hftrace=0/1'); $ trace initialisation
     229
     230
     231      if q2_init_type = 0 then        $ standard initialisation
     232
     233          file q2_file access = read, title = q2_title;
     234          call chkq2f(q2_file, q2_checkw, oldest_q2, newest_q2);
     235          call rdheap(q2_file);       $ read the standard q2 file
     236          file q2_file access = release;
     237
     238      elseif q2_init_type = 1 then    $ mapped initialisation
     239
     240          file q2e_file access = read, title = q2e_title;
     241          call chkq2f(q2e_file, q2e_checkw, oldest_q2e, newest_q2e);
     242          call rdheap1(q2e_file);     $ read the environment block
     243
     244          $ read the section table from the q2 e file
     245          read q2e_file, first, last;
     246          read q2e_file, hftab_first(first) to hftab_first(last);
     247          read q2e_file, first, hftabp;
     248          read q2e_file, hftab_last(first) to hftab_last(hftabp);
     249
     250          $ map the q2 h file into the paging table
     251          call getspace(h_lim, yes);
     252          call hfmapr(no);
     253
     254          $ the form table really should be integrated into the heap.
     255          +* get_slice(file, table, first, last)  =
     256              read file, first, last;
     257              if first <= last then
     258                  read file, table(first) to table(last);
     259              end if;
     260              **
     261
     262          get_slice(q2e_file,  a_formtab,         1,  formtabp+1)
     263          get_slice(q2e_file,      mttab,         1,      mttabp)
     264
     265          macdrop(get_slice)
     266
     267          file q2e_file access = release;
     268
     269      elseif q2_init_type = 2 then    $ build mapped files
     270
     271          $ open the standard q2 file and check its format
     272          file q2_file access = read, title = q2_title;
     273          call chkq2f(q2_file, q2_checkw, oldest_q2, newest_q2);
     274
     275          $ create the q2 e file
     276          file q2e_file access = write, title = q2e_title;
     277          write q2e_file, q2e_checkw, current_q2e;
     278
     279          call rdheap1(q2_file);      $ read the environment block
     280          call getspace(h_lim, yes);  $ allocate a heap of proper size
     281          call hfcrst;                $ build the section table
     282          call hfmapr(yes);           $ open section file for creation
     283
     284          $ read the heap again to copy it to the section file
     285          rewind q2_file;
     286          call chkq2f(q2_file, q2_checkw, oldest_q2, newest_q2);
     287          call rdheap(q2_file);
     288
     289          $ finally write the environment file
     290          call wrheap1(q2e_file);     $ write the environment block
     291
     292          $ write the section table to the q2 e file
     293          write q2e_file, 1, hftabp;
     294          write q2e_file, hftab_first(1) to hftab_first(hftabp);
     295          write q2e_file, 1, hftabp;
     296          write q2e_file, hftab_last(1) to hftab_last(hftabp);
     297
     298          $ the form table really should be integrated into the heap.
     299          +* put_slice(file, table, first, last)  =
     300              write file, first, last;
     301              if first <= last then
     302                  write file, table(first) to table(last);
     303              end if;
     304              **
     305
     306          put_slice(q2e_file,  a_formtab,         1,  formtabp+1)
     307          put_slice(q2e_file,      mttab,         1,      mttabp)
     308
     309          macdrop(put_slice)
     310
     311          file q2_file  access = release;
     312          file q2e_file access = release;
     313
     314          call libterm(0);
     315      end if;
     316
     317 ..s32
     318 ..hf
     319
     320
     321      $ increase the heap size if so desired
     322      call getspace(ih_lim, no);
     323      init_heap_len = h_lim;
     324
     325
     326 .+mc.
     327      call getipp(socase,'socase=0/0');
     328      if (socase) call fixcas(socase);  $ adjust case for type
     329 ..mc
     330      $ dump the initial heap image if so requested
     331      if (d_flag) call dumpds1;
     332
     333      $ execution starts now:
     334      runtime_flag = yes;
     335
     336
     337      end subr libini;
     338
     339 .+tr notrace entry;          $ do not trace entry for interpreter
     340
       1 .=member rdheap
       2      subr rdheap(id);
       3$
       4$ this routine reads the q2 file from file id.
       5$
       6      size id(ps);            $ little file identifier for q2 file
       7
       8
       9      call rdheap1(id);       $ read the environment block
      10      if (filestat(id, end))  return;
      11      call rdheap2(id);       $ read the heap proper
      12
      13
      14      end subr rdheap;
       1 .=member rdheap1
       2      subr rdheap1(id);
       3$
       4$ this routine reads the environment block from file id.
       5$
       6      size id(ps);            $ little file identifier for q2 file
       7
       8
       9      $ read environment parameters
      10      read id,
      11          snam_org, snam_end, $ names table
      12          sym_org, sym_end,   $ symbol table
      13          ca_org, h_org, h,   $ heap
      14          t, savet, h_lim,    $ stack
      15          formtabp, mttabp,   $ form table
      16          codep,              $ program counter
      17          cur_na,             $ number of arguments for the current proc
      18          back_flag,          $ back tracking allowed
      19          last_env,           $ pointer to last environment block
      20          cur_arg,            $ pointer to current stack argument
      21          ok_lev,             $ number of ok's currently being saved
      22          spare9, spare8,     $ space for future expansion
      23          spare7, spare6, spare5, spare4,
      24          spare3, spare2, spare1, spare0;
      25
      26      $ check for end-of-file
      27      if (filestat(id, end)) return;
      28
      29      $ read addresses of standard values
      30      read id,
      31          err_mode, back_flag, s_true, s_false, s_okval,
      32          s_fid, s_free, s_fmax, s_fmode, s_io1, s_io2,
      33          s_pair, s_stat, s_ss1, s_ss2,
      34          s_ovar, s_scopes, s_rnspec, s_rnames,
      35          s_intf,
      36          a_s_types, st_lo, st_hi, st_no;
      37
      38      $ read spares for expansion
      39      read id,
      40          s_spare2,
      41          s_spare3,
      42          s_spare4,
      43          s_spare5,
      44          s_spare6,
      45          s_spare7,
      46          s_spare8,
      47          s_spare9,
      48          s_sparea,
      49          s_spareb,
      50          s_sparec,
      51          s_spared,
      52          s_sparee,
      53          s_sparef,
      54          s_spareg,
      55          s_spareh,
      56          s_sparei,
      57          s_sparej,
      58          s_sparek;
      59
      60
      61      end subr rdheap1;
       1 .=member rdheap2
       2      subr rdheap2(id);
       3$
       4$ this routine read the heap proper from the file id.
       5$
       6      size id(ps);            $ little file identifier for the q2 file
       7
       8      size first(ps);         $ first component of table
       9      size last(ps);          $ last component of table
      10
      11
      12$
      13$ allocate a heap the same size as the one built by the code generator.
      14$
      15      call getspace(h_lim, yes);
      16$
      17$ read the heap
      18$
      19$ we read the total dynamic storage in the following slices:
      20$    -   the run time names table
      21$    -   the symbol table
      22$    -   the constant area
      23$    -   the heap proper
      24$    -   the stack
      25$    -   the form table (formtab and mttab)
      26$
      27      +* get_slice(file, table, first, last)  =
      28          read file, first, last;
      29          if (first <= last) read file, table(first) to table(last);
      30          **
      31
      32      get_slice(id,       heap,  first,  last)
      33      get_slice(id,       heap,  first,  last)
      34      get_slice(id,       heap,  first,  last)
      35      get_slice(id,       heap,  first,  last)
smfb  67      get_slice(id,       heap,  first,  last)
      36      get_slice(id,       heap,  first,  last)
      37      get_slice(id,  a_formtab,  first,  last)
      38      get_slice(id,      mttab,  first,  last)
      39
      40      macdrop(get_slice)
      41
      42
      43      end subr rdheap2;
       1 .=member chkq2f
       2      subr chkq2f(id, file_check, oldest_date, newest_date);
       3$
       4$ this routine checks the file format of the q2 file, and report any
       5$ errors.
       6$
       7      size id(ps);            $ little file identifier for the q2 file
       8      size file_check(ws);    $ check word
       9      size oldest_date(ws);   $ oldest valid date
      10      size newest_date(ws);   $ newest valid date
      11
      12
      13      if (filestat(id, end))        call libterm(0);
      14
      15      read id, check_word;
      16      if (check_word ^= file_check) call err_q2(1);
      17      if (filestat(id, end))        call err_q2(2);
      18
      19      read id, date_stamp;
      20      if (date_stamp < oldest_date) call err_q2(3);
      21      if (date_stamp > newest_date) call err_q2(3);
      22      if (filestat(id, end))        call err_q2(2);
      23
      24
      25      end subr chkq2f;
       1 .=member wrheap
       2      subr wrheap(id);
       3$
       4$ this routine writes the q2 file to file id.
       5$
       6      size id(ps);            $ little file identifier for q2 file
       7
       8
       9      call wrheap1(id);       $ write environment block
      10      call wrheap2(id);       $ write heap proper
      11
      12
      13      end subr wrheap;
       1 .=member wrheap1
       2      subr wrheap1(id);
       3$
       4$ this routine writes the environment block of the q2 file to file id.
       5$
       6      size id(ps);            $ little file identifier for the q2 file
       7
       8
       9      $ write environment parameters
      10      write id,
      11          snam_org, snam_end, $ names table
      12          sym_org, sym_end,   $ symbol table
      13          ca_org, h_org, h,   $ heap
      14          t, savet, h_lim,    $ stack
      15          formtabp, mttabp,   $ form table
      16          codep,              $ program counter
      17          cur_na,             $ number of arguments for the current proc
      18          back_flag,          $ back tracking allowed
      19          last_env,           $ pointer to last environment block
      20          cur_arg,            $ pointer to current stack argument
      21          ok_lev,             $ number of ok's currently being saved
      22          spare9, spare8,     $ space for future expansion
      23          spare7, spare6, spare5, spare4,
      24          spare3, spare2, spare1, spare0;
      25
      26      $ write various standard values
      27      write id,
      28          err_mode, back_flag, s_true, s_false, s_okval,
      29          s_fid, s_free, s_fmax, s_fmode, s_io1, s_io2,
      30          s_pair, s_stat, s_ss1, s_ss2,
      31          s_ovar, s_scopes, s_rnspec, s_rnames,
      32          s_intf,
      33          a_s_types, st_lo, st_hi, st_no;
      34
      35      $ write spares for future expansions
      36      write id,
      37          s_spare2,
      38          s_spare3,
      39          s_spare4,
      40          s_spare5,
      41          s_spare6,
      42          s_spare7,
      43          s_spare8,
      44          s_spare9,
      45          s_sparea,
      46          s_spareb,
      47          s_sparec,
      48          s_spared,
      49          s_sparee,
      50          s_sparef,
      51          s_spareg,
      52          s_spareh,
      53          s_sparei,
      54          s_sparej,
      55          s_sparek;
      56
      57
      58      end subr wrheap1;
       1 .=member wrheap2
       2      subr wrheap2(id);
       3$
       4$ this routine writes the heap to the file id.
       5$
       6      size id(ps);            $ little file identifier
       7
       8
       9      $ write the heap and related tables
      10
      11      +* put_slice(file, table, first, last)  =
      12          write file, first, last;
      13          if (first <= last) write file, table(first) to table(last);
      14          **
      15
      16      put_slice(id,       heap,  snam_org,    snam_end)  $ names table
      17      put_slice(id,       heap,   sym_org,     sym_end)  $ symbol table
      18      put_slice(id,       heap,    ca_org,     h_org-1)  $ constants
      19      put_slice(id,       heap,     h_org,         h-1)  $ heap proper
smfb  68      put_slice(id,       heap,         h,         h-1)  $ dummy slice
      20      put_slice(id,       heap,     savet,       h_lim)  $ stack
      21
      22      put_slice(id,  a_formtab,         1,  formtabp+1)  $ form table
      23      put_slice(id,      mttab,         1,      mttabp)  $ ...
      24
      25      macdrop(put_slice)
      26
      27
      28      end subr wrheap2;
       1 .=member hfcrst
       2
       3
       4 .+hf.                        $ heap file mapped to paging file
       5 .+s32.                       $   -  for the vax under vms
       6
       7
       8      subr hfcrst;
       9$
      10$ this routine computes the page indices for the heap slices by
      11$ reading though the heap slice portion of the q2 file.  thus it
      12$ assumes that rdheap1 has been called prior to this routine.
      13$
      14      access nshf;
      15$
      16$ obtain heap indices for slice, skip over data.
      17$ then convert heap indices to page offsets.  report error
      18$ if slice begins before end of prior slice.  if slice begins
      19$ at same page as end of prior slice, must extend the prior
      20$ slice.  otherwise, build a new table entry.
      21$ nb. a page can be mapped once and only once, so it is not an
      22$ optimisation to note if the first page p2 of a slice s2 equals the
      23$ last page p1 of the preceding slice s1.  it is, however, an
      24$ optimisation to note that two pages p1 and p2 are contiguous, i.e.
      25$ that p2 = p1+1.
      26
      27      size first(ps);         $ first entry of table
      28      size last(ps);          $ last entry of table
      29      size pagcnt(ws);        $ page count for slice
      30      size total_pages(ps);   $ total number of pages mapped
      31      size i(ps);             $ loop index over heap slices
      32
      33
      34      do i = 1 to hf_slices; $ number of slices
      35
      36          read q2_file, first, last;
      37          if (first > last) cont do i;  $ empty slice
      38
      39          $ skip over the slice
      40          read q2_file, heap(first) to heap(last);
      41
      42          if hf_trace then
      43              put ,'hfcrst heap indices: ' :first :last ,nil(10) ,skip;
      44          end if;
      45
      46          $ convert to page offsets
      47          first = pageof(first);   last = pageof(last);
      48
      49          if hftabp = 0  then $ if first slice
      50              hftabp = 1;
      51              hftab_first(hftabp) = first;
      52              hftab_last(hftabp)  =  last;
      53
      54          elseif first < hftab_last(hftabp) then
      55              $ pages overlap: fatal error
      56              call err_fatal(56);
      57
      58          elseif first <= hftab_last(hftabp)+1 then
      59              $ if slice contiguous to prior one,just extend prior one
      60              hftab_last(hftabp) = last;
      61
      62          else
      63              $ create a new slice
      64              hftabp = hftabp + 1;
      65              hftab_first(hftabp) = first;
      66              hftab_last(hftabp)  = last;
      67          end if;
      68      end do;
      69
      70      if hf_trace then
      71          total_pages = 0;    $ total number of pages mapped
      72
      73          put ,skip
      74              ,'page section table:'                    ,skip(2)
      75              ,'index    first     last         length' ,skip
      76              ,'-----    -----     ----         ------' ,skip(2);
      77
      78          do i = 1 to hftabp;
      79              pagcnt = hftab_last(i) - hftab_first(i) + 1;
      80              total_pages = total_pages + pagcnt;
      81
      82              put :i,i(5)              ,x
      83                  :hftab_first(i),i(8) ,x
      84                  :hftab_last(i),i(8)  ,x
      85                  :pagcnt,i(8)         ,x
      86                  ,' (' :(pagcnt*512),i(10) ,'.)'
      87                  ,skip;
      88          end do;
      89
      90          put ,skip
      91              ,'mapping ' :total_pages,i ,' pages of the heap.' ,skip;
      92      end if;
      93
      94
      95      end subr hfcrst;
       1 .=member hfmapr
       2      subr hfmapr(rw);
       3$
       4$ this routine interfaces to vms to map the heap file.  the parameter
       5$ rw indicates whether the heap file is read (rw=0) or created (rw=1).
       6$
       7      access nshf;
       8
       9$ map heap to file.  rw is zero if reading the section file,
      10$ nonzero to write (create) it.
      11
      12      size rw(ps);            $ flags creation mode
      13
      14      size rc(ws);            $ return code
      15
      16      size inadr(ws);         $ array containing the starting and
      17      dims inadr(2);          $  ending virtual addresses in the
      18                              $  process's virtual address space into
      19                              $  which the section is to be mapped.
      20      size retadr(ws);        $ array to receive the starting and
      21      dims retadr(2);         $  ending virtual addresses of the pages
      22                              $  into which the section was actually
      23                              $  mapped
      24      size chan(ws);          $ vms number of the channel on which the
      25                              $  file has been accessed.
      26      size pagcnt(ws);        $ number of pages in the section
      27      size vbn(ws);           $ virtual block number in the file that
      28                              $  marks the beginning of the section
      29
      30      size nara(ws);          $ file name as vms string
      31      dims nara(20);
      32
      33      size totpages(ws);      $ total number of pages to be mapped
      34      size i(ps);             $ loop index
      35
      36      size c(cs),wp(ps),cp(cs);
      37
      38      $ assuming byte addressing, 4 bytes/word, 512 bytes/page, get
      39      $ the actual heap address.
      40      hf_heap_adr = mptr(heap) * 4;
      41      hf_heap_nsadr = hf_heap_adr;
      42
      43      .f. 1, 9, hf_heap_nsadr = 0; $ get address of start of nameset
      44      hf_org = mod(hf_heap_adr, 512);
      45
      46      $ convert little sds-string into a format acceptable to the
      47      $ vms rms open system service.
      48      wp = 0; cp = ws+1;
      49      do i = 1 to .len. q2h_title;
      50          if cp = ws+1 then wp = wp + 1; cp = 1; nara(wp) = 0; end if;
      51          .f. cp, 8, nara(wp) =  .ch. i, q2h_title;   cp = cp + 8;
      52      end do;
      53
      54      $ determine the total number of pages mapped
      55      totpages = 0;   vbn = 1;
      56      do i = 1 to hftabp;
      57          totpages = totpages + hftab_last(i) - hftab_first(i) + 1;
      58      end do;
      59
      60      $ open the heap file
      61      call hfopen(rc, chan, rw, totpages, nara, (.len. q2h_title));
      62      if .f. 1, 1, rc ^= 1 then
      63          put ,'error opening mapped heap file ' :q2h_title,a ,skip;
      64          put ,'return code ' :rc,b(12,4),skip;
      65          call libterm(0);
      66      end if;
      67
      68      $ map each heap slice
      69      if hf_trace then
      70          put ,skip
      71              ,'heap section table:' ,skip(2)
      72              ,'index pages disk vbn channel '
      73              ,'  base     last           length'
      74              ,skip
      75              ,'----- ----- -------- ------- '
      76              ,'  ----     ----           ------'
      77              ,skip;
      78      end if;
      79      do i = 1 to hftabp;
      80          inadr(1) = hf_heap_nsadr + 512 * (hftab_first(i)-1);
      81          inadr(2) = hf_heap_nsadr + 512 * (hftab_last(i) - 1) + 511;
      82          pagcnt   = hftab_last(i) - hftab_first(i) + 1;
      83          if hf_trace then
      84              put ,skip
      85                  :i,i(5)          ,x
      86                  :pagcnt,i(5)     ,x
      87                  :vbn,i(8)        ,x
      88                  :chan,i(7)       ,x
      89                  :inadr(1),b(8,4) ,x
      90                  :inadr(2),b(8,4) ,x
      91                  :pagcnt*512,b(8,4) ,' (' :pagcnt*512,i(10) ,'.)'
      92                  ,skip;
      93          end if;
      94
      95          call hfcrms(rc, retadr, rw, chan, inadr, pagcnt, vbn);
      96
      97          if hf_trace then
      98              put ,x(29)
      99                  :retadr(1),b(8,4) ,x
     100                  :retadr(2),b(8,4) ,x
     101                  :pagcnt*512,b(8,4) ,' (' :pagcnt*512,i(10) ,'.)'
     102                  ,skip;
     103          end if;
     104
     105          if .f. 1, 1, rc ^= 1 then
     106              put ,'error mapping heap file',skip;
     107              put ,'return code ' :rc,b(12,4),skip;
     108              call libterm(0);
     109          end if;
     110
     111          vbn = vbn + pagcnt;
     112      end do;
     113
     114      rc = 0;
     115
     116
     117      end subr hfmapr;
     118
     119
     120      macdrop(pageof) macdrop(mptr) macdrop(hf_slices)
     121
     122
     123 ..s32
     124 ..hf
     125
     126 .+tr notrace entry;          $ do not trace entry for interpreter
     127
       1 .=member interp
       2      subr interp;            $ main interpreter
       3
       4$ this is the main routine of the interpreter. it is originally
       5$ called from -lib-, and is driven by the -q2- quadruples. each
       6$ of the cases below corresponds to a -q2- primitive which will
       7$ eventually be generated as inline code. a few of them call
       8$ the library; the remainder do their work completely in line.
       9
      10$ due to the limited size of the little compiler, this routine is
      11$ sub-divided into four routines, called -interp1- ... -interp4-.
      12$ the top-level routine -interp- merely decodes the current
      13$ instruction, and then calls the approrpiate subroutine.
      14
      15$ interface with the garbage collector
      16
      17$ garbage collections may result either from storage requests within
      18$ -interp- or from requests in the library routines it calles.  the
      19$ latter case poses special problems since library routines may
      20$ have assigned pointers to local variables before the garbage
      21$ collection takes place. in order to avoid these problems, we
      22$ assume that the library never runs out of space, and use
      23$ backtracking to make sure our assumption is correct.
      24$ more specificly: the garbage collector may be called either from
      25$ the interpreter or the library, however it never executes a return.
      26$ instead it backs up the interpreter by one instruction and
      27$ reactivates it. the library routines which ran out of space are
      28$ performed a second time, and thus have no need to hold onto
      29$ any pointers.
      30
      31$ the garbage collector will always restore the recursion stack to
      32$ its status prior to entering the library. this means that the
      33$ value of -t- must be saved at the beginning of executiion and
      34$ every time it is adjusted by the interpreter.
      35
      36
      37$ the interpreter includes various trace features. these are all
      38$ part of the condtional assembly group 'ct'(c-ode t-race).
      39
      40
      41$ the current quadruple pointer -codep- is global. thus allows
      42$ both the garbage collector and various dump routines to access
      43$ it. the remaining variables used by the interpreter are stored
      44$ in a seperate nameset. this allows them to be accessed by interp2.
      45
      46      nameset nsintp;
      47
      48          size a1(ps),    $ arguments of current quadruple
      49               a2(ps),
      50               a3(ps);
      51
      52          size a4(ps),   $ additional arguments, gotten from the next qu
      53               a5(ps),   $ quadruple
      54               a6(ps);
      55
      56          size op(ps);  $ current opcode
      57
      58          size t1(hs),   $ temporaries used to achieve value return on
      59               t2(hs),   $ library calls. heap entries cant be passed
      60               t3(hs),   $ directly if value return is desired
      61               t4(hs),
      62               t5(hs),
      63               t6(hs);
      64
      65          size p(ps),    $ misc. pointer
      66               p1(ps),
      67               pos(ps);  $ pointer returned by locate
      68
      69          size j(ps),         $ loop index
      70               indx(ps),      $ tuple index
      71               card(ps),      $ cardinality (or nelt) of tuple
      72               ss(ssz),       $ string specifier
      73               lsw(ps),       $ ls_word of local set
      74               lsb(ps),       $ ls_bit value
      75               ebb(ps),       $ ls_bit of local set
      76               temp(hs);      $ heap sized temporary
      77
      78$ there are three variables used for backtracking:
      79
      80$ cur_env:  points to current environment when tracing thru stack
      81$ prev_env: points to previous environment
      82$ cur_arg:  points to current argument when doing q2_bpop, etc.
      83
      84          size cur_env(ps);   $ pointer to current environment block
      85          size prev_env(ps);  $ pointer to previous environment block
      86
      87          data cur_env  = 0;
      88          data prev_env = 0;
      89
      90 .+ct     size ctrace(1);  $ on if tracing interpreter
      91 .+ct     data ctrace = no;
      92
      93
      94          size init(1);  $ flags first call to interpreter
      95          data init = yes;
      96
      97          size entry_time(ws);  $ cpu time on first entry to library
      98
      99          real real1,   $ real temporaries
     100               real2;
     101
     102      end nameset nsintp;
     103
     104
     105
     106$ we enter the interpreter under one of two conditions:
     107
     108$ 1. we are about to start the main program.  in this case we
     109$    initialize the meaurements.
     110
     111$ 2. we have just done a garbage collection, and we simply
     112$    continue where we left off.
     113
     114      if init then
     115          init = no;
     116
     117          call letime(entry_time);
     118      end if;
     119
     120 .+s32u.
     121      if (vadvise&2)  call _vadvice(1);
     122 ..s32u
sunb  29 .+s68.
sunb  30      if (vadvise&2) call _vadvice(1);
sunb  31 ..s68
     123
     124      while 1;                $ main loop.  this loop is terminated
     125                              $ by a call to libterm in one of the
     126                              $ interpreter routines.
     127
     128          itotal = itotal + 1;
     129
     130 .+ct     if (ctrace) call dinst(codep);
     131
     132 .+ic     if (codep = 0) call err_fatal(2);
     133
     134$ unpack the current instruction
     135
     136          op = codeop(codep);
     137
     138          a1 = codea1(codep);
     139          a2 = codea2(codep);
     140          a3 = codea3(codep);
     141
     142$ initialize measurements
     143
     144 .+st     add_stat(st_nubbin, op_time(op));
     145
     146
     147$ check op range and branch to appropriate interpreter routine
     148
stra  14      if op <= q2_ssubst then
stra  15          if op <= q2_ninr then
stra  16 .+ic         if (op < q2_minimum) call err_fatal(3);
stra  17              call intrp1;
stra  18          else    $ op > q2_ninr
stra  19              call intrp2;
stra  20          end if;
stra  21      else    $ op > q2_ssubst
stra  22          if op <= q2_nextd then
stra  23              call intrp3;
stra  24          else    $ op > q2_nextd
stra  25 .+ic         if (op > q2_maximum) call err_fatal(3);
stra  26              call intrp4;
stra  27          end if;
stra  28      end if;
     164
     165 .+st     save_time(st_lib);
     166
     167$ we will sometimes compile the library with the 'icr' option
     168$ turned on for all routines except the interpreter. when we do this,
     169$ the st_lib category will include all the time spent in general library
     170$ routines, excluding the interpreter.
     171
     172$ each of the four interpreter routines begins with the macro
     173$ 'init_time(st_lib)'. this initializes the counter for library
     174$ time to icr_zero. icr_zero is a negative number equal to 0 -
     175$ the cost of the calls to icrsel, icrput, and icrget which occur
     176$ in the interpreter.
     177
     178$ when we compile the interpreter with the icr option off, we will
     179$ not charge for these calls. this may cause the library time to
     180$ appear negative. we include conditional code to correct for this.
     181
     182 .+sti add_stat(st_lib, - icr_zero);
     183
     184
     185      end while;
     186
     187
     188      end subr interp;
       1 .=member intrp1
       2      subr intrp1;
       3
       4
       5      access nsintp;
       6
       7      size add(hs),     addli(hs),   addstr(hs),  addtup(hs),
       8           diff(hs),    diffli(hs),
       9           mult(hs),    multli(hs),  multstr(hs), multtup(hs),
      10           slash(hs),
      11           div(hs),     divli(hs),
      12           smod(hs),    modli(hs),
      13           sexp(hs),
      14           shiftl(hs),
      15           shiftr(hs),
      16           real_over(1),
      17           real_under(1),
      18           union(hs),     unset(hs),   unlset(hs),  unrset(hs),
      19           intersect(hs), inset(hs),   inlset(hs),  inrset(hs),
      20           setdiff(hs),   difset(hs),  diflset(hs), difrset(hs),
      21           setmod(hs),
      22           member(1),   memset(1),
      23           incs(1),
      24           lt(1),
      26           equal(1),    nullp(1),
      27           with(hs),    withs(hs),   withm(hs),
      28           less(hs),
      29           lessf(hs),
      30           npow(hs),
      31           atan2f(hs),
      32           smin(hs),
      33           smax(hs),
      34           copy1(hs),   convert(hs);
      35
      36
      37 .+st  init_time(st_lib);      $ start measuring library time
      38
      39      go to case(op) in q2_copy to q2_ninr;
      40
      41
      42$ section 1: utilities
      43$ ------- -- ---------
      44
      45/case(q2_copy)/                  $ copy
      46
      47      heap(a1) = copy1(heap(a2));
      48      go to nxt;
      49
      50
      51
      52/case(q2_ccopy)/                 $ copy if share bit set.
      53
      54      heap(a1) = heap(a2);
      55      maycopy(heap(a1));
      56      go to nxt;
      57
      58
      59/case(q2_share)/  $ set share bit of a1
      60
      61      is_shared(a1) = yes;
      62      go to nxt;
      63
      64
      65$ section 2: binary operators
      66$ ------- -- ------ ---------
      67
      68$ these operations all take the form:
      69
      70$ a1 = a2 -op- a3
      71
      72
      73
      74
      75$ general arithmetic: +, -, *, /, and // on undeclared variables
      76
      77$ these cases begin by trying to perform short integer arithmetic.
      78$ if this yields an overflow, the inputs are probably not short ints,
      79$ so we go off line. otherwise we have our answer.
      80
      81/case(q2_add)/                   $ +
      82
      83      t2   = heap(a2);
      84      t3   = heap(a3);
      85      temp = otvalue_ t2 + otvalue_ t3;
      86
      87      if temp <= maxsi then
      88          otvalue(a1) = temp;
      89      else
      90          heap(a1) = add(t2, t3, codea4(codep));
      91      end if;
      92
      93      go to nxt;
      94
      95
      96
      97/case(q2_div)/                   $ /
      98
      99      if otvalue(a2) > maxsi ! otvalue(a3) > maxsi then
     100          heap(a1) = div(heap(a2), heap(a3));
     101
     102      elseif value(a3) = 0 then  $ division by 0
     103
     104          call err_misc(1);
     105          otvalue(a1) = err_val(f_gen);
     106
     107      else
     108          otvalue(a1) = otvalue(a2) / otvalue(a3);
     109      end if;
     110
     111      go to nxt;
     112
     113
     114
     115/case(q2_mult)/                  $ *
     116
     117      if .fb. otvalue(a2) + .fb. otvalue(a3) > .fb. maxsi then
     118          heap(a1) = mult(heap(a2), heap(a3), codea4(codep));
     119      else
     120          otvalue(a1) = otvalue(a2) * otvalue(a3);
     121      end if;
     122
     123      go to nxt;
     124
     125
     126
     127/case(q2_sub)/                   $ -
     128
     129      if otvalue(a2) > maxsi ! otvalue(a3) > maxsi then
     130          heap(a1) = diff(heap(a2), heap(a3), codea4(codep));
     131      else
     132          temp = otvalue(a2) - otvalue(a3);
     133
     134          if temp < 0 then
     135              heap(a1) = diffli(heap(a2), heap(a3));
     136          else
     137              otvalue(a1) = temp;
     138          end if;
     139      end if;
     140
     141      go to nxt;
     142
     143
     144
     145/case(q2_mod)/                   $ //
     146
mjsa  20      if otvalue(a2) <= maxsi & otvalue(a3) <= maxsi then
     148          otvalue(a1) = mod(otvalue(a2), otvalue(a3));  $ little mod fun
     149
     150      else
     151          heap(a1) = smod(heap(a2), heap(a3));  $ setl mod function
     152      end if;
     153
     154      go to nxt;
     155
     156
     157/case(q2_slash)/      $ division yielding real
     158
     159      if (otvalue(a2) <= maxsi & otvalue(a3) <= maxsi)
     160          go to case(q2_slashi);
     161
     162      heap(a1) = slash(heap(a2), heap(a3));
     163      go to nxt;
     164
     165
     166
     167 /case(q2_exp)/
     168
     169      heap(a1) = sexp(heap(a2), heap(a3));
     170      go to nxt;
     171
     172
     173
     174                              $ short integer arithmetic,
     175
     176$ these operations include no overflow checks. when such checks are
     177$ needed we use the general purpose arithmetic operations.
     178
     179
     180/case(q2_addi)/                  $ +
     181
     182      otvalue(a1) = otvalue(a2) + otvalue(a3);
     183      go to nxt;
     184
     185
     186/case(q2_inci)/               $ increment counter
     187
     188      add1(heap(a1));
     189
     190      go to nxt;
     191
     192
     193/case(q2_divi)/               $ a1 := a2 div a3
     194
     195      if otvalue(a3) = 0 then
     196          call err_misc(2);
     197          heap(a1) = err_val(f_gen);
     198
     199      else
     200          otvalue(a1) = otvalue(a2) / otvalue(a3);
     201      end if;
     202
     203      go to nxt;
     204
     205
     206/case(q2_modi)/                  $ //
     207
     208      otvalue(a1) = mod(otvalue(a2), otvalue(a3));
     209
     210      go to nxt;
     211
     212
     213/case(q2_slashi)/   $ division yielding real
     214
     215      get_real(p);
     216
     217      real1 = float(ivalue(a2));
     218      real2 = float(ivalue(a3));
     219
     220      if real2 = 0.0 then
     221          call err_misc(01);
     222          heap(a1) = err_val(f_gen);
     223      else
     224          rval(p) = real1 / real2;
     225      end if;
     226
     227      build_spec(heap(a1), t_real, p);
     228      go to nxt;
     229
     230
     231
     232
     233
     234/case(q2_multi)/
     235
     236      otvalue(a1) = otvalue(a2) * otvalue(a3);
     237      go to nxt;
     238
     239
     240
     241/case(q2_subi)/                  $ -
     242
     243      otvalue(a1) = otvalue(a2) - otvalue(a3);
     244      go to nxt;
     245
     246
     247
     248/case(q2_shiftl)/                $ multiply by power of two
     249                              $ a3 is the number of places to shift.
     250      otvalue(a1) = shiftl(otvalue(a2), a3);
     251      go to nxt;
     252
     253
     254
     255/case(q2_shiftr)/                $ divide by power of 2
     256
     257      otvalue(a1) = shiftr(otvalue(a2), a3);
     258      go to nxt;
     259
     260
     261
     262$ untyped integer arithmetic
     263
     264
     265/case(q2_addui)/    $ +
     266
     267      heap(a1) = heap(a2) + heap(a3);
     268      go to nxt;
     269
     270
     271/case(q2_incui)/              $ increment counter
     272
     273      heap(a1) = heap(a1) + 1;
     274
     275      go to nxt;
     276
     277
     278/case(q2_divui)/  $ /
     279
     280      if heap(a3) = 0 then
     281          call err_misc(3);
     282          heap(a1) = err_val(f_uint);
     283      else
     284          heap(a1) = heap(a2) / heap(a3);
     285      end if;
     286
     287       go to nxt;
     288
     289
     290/case(q2_multui)/  $ *
     291
     292      heap(a1) = heap(a2) * heap(a3);
     293
     294      go to nxt;
     295
     296
     297/case(q2_modui)/   $ //
     298
mjsa  21      temp = mod(heap(a2), heap(a3));
smfc  20      if (temp < 0) temp = temp + iabs(heap(a3));
mjsa  23      heap(a1) = temp;
     300      go to nxt;
     301
     302
     303/case(q2_slashui)/    $ division yielding umtyped real
     304
     305      real1 = float(heap(a2));
     306      real2 = float(heap(a3));
     307
     308      if real2 = 0.0 then
     309          call err_misc(01);
     310          heap(a1) = err_val(f_ureal);
     311      else
     312          heap(a1) = real1 / real2;
     313      end if;
     314
     315      go to nxt;
     316
     317
     318
     319/case(q2_subui)/  $ -
     320
     321      heap(a1) = heap(a2) - heap(a3);
     322      go to nxt;
     323
     324
     325
     326/case(q2_shiftlui)/   $ shift left
     327
     328      heap(a1) = shiftl(heap(a2), a3);
     329      go to nxt;
     330
     331
     332
     333/case(q2_shiftrui)/
     334
     335      heap(a1) = shiftr(heap(a2), a3);
     336      go to nxt;
     337
     338
     339
     340/case(q2_over)/
     341
     342      if (heap(a2) > maxsi) call err_misc(4);
     343
     344      go to nxt;
     345
     346
     347
     348/case(q2_under)/
     349                              $ short integer underflow
     350      if (heap(a2) < 0) call err_misc(5);
     351
     352      go to nxt;
     353
     354
     355
     356                              $ untyped real arithmetic
     357
     358$ these operations contain no overflow checks. seperate overflow
     359$ check operations are provided.
     360
     361/case(q2_addur)/                 $ +
     362
     363      real1 = heap(a2);            $ assign to real temps.
     364      real2 = heap(a3);
     365      heap(a1) = real1 + real2;
     366      go to nxt;
     367
     368
     369
     370/case(q2_multur)/                $ *
     371
     372      real1 = heap(a2);
     373      real2 = heap(a3);
     374      heap(a1) = real1 * real2;
     375      go to nxt;
     376
     377
     378/case(q2_slashur)/   $ -/- on untyped reals
     379
     380      real1 = heap(a2);
     381      real2 = heap(a3);
     382
     383      if real2 = 0.0 then
     384          call err_misc(01);
     385          heap(a1) = err_val(f_ureal);
     386      else
     387          heap(a1) = real1 / real2;
     388      end if;
     389
     390      go to nxt;
     391
     392
     393
     394/case(q2_subur)/                 $ -
     395
     396      real1 = heap(a2);
     397      real2 = heap(a3);
     398      heap(a1) = real1 - real2;
     399      go to nxt;
     400
     401
     402
     403/case(q2_rover)/                 $ real overflow
     404$ this is a no-op on machines with built in checking
     405
     406      if (real_over(heap(a2))) call err_misc(7);
     407
     408      go to nxt;
     409
     410
     411
     412/case(q2_runder)/                $ real underflow. see note above
     413
     414      if (real_under(heap(a2))) call err_misc(8);
     415
     416      go to nxt;
     417
     418
     419
     420
     421
     422
     423
     424                              $ long arithmetic
     425
     426/case(q2_addli)/               $ add long integers
     427
     428      t2   = heap(a2);
     429      t3   = heap(a3);
     430      temp = otvalue_ t2 + otvalue_ t3;
     431
     432      if temp <= maxsi then
     433          otvalue(a1) = temp;
     434      else
     435          heap(a1) = addli(t2, t3);
     436      end if;
     437
     438      go to nxt;
     439
     440
     441/case(q2_addtup)/       $ tuple concatenation
     442
     443      heap(a1) = addtup(heap(a2), heap(a3));
     444      go to nxt;
     445
     446
     447
     448/case(q2_addstr)/     $ string concatenation
     449
     450      heap(a1) = addstr(heap(a2), heap(a3));
     451      go to nxt;
     452
     453
     454
     455/case(q2_diffli)/         $ long integer subtraction
     456
     457      t2 = heap(a2);   t4 = otvalue_ t2;
     458      t3 = heap(a3);   t5 = otvalue_ t3;
     459
     460      if t4 <= maxsi & t5 <= maxsi & t4 >= t5 then
     461          otvalue(a1) = t4 - t5;
     462      else
     463          heap(a1) = diffli(t2, t3);
     464      end if;
     465
     466      go to nxt;
     467
     468
     469
     470/case(q2_divli)/               $ long integer division
     471
     472      t2 = heap(a2);   t4 = otvalue_ t2;
     473      t3 = heap(a3);   t5 = otvalue_ t3;
     474
     475      if t5 = 0 then
     476          call err_misc(01);
     477          heap(a1) = err_val(f_gen);
     478      elseif t4 <= maxsi & t5 <= maxsi then
     479          otvalue(a1) = t4 / t5;
     480      else
     481          heap(a1) = divli(t2, t3);
     482      end if;
     483
     484      go to nxt;
     485
     486
     487
     488/case(q2_modli)/             $ modulo on long integers
     489
     490      heap(a1) = modli(heap(a2), heap(a3));
     491      go to nxt;
     492
     493
     494
     495/case(q2_multli)/         $ long integer multiply
     496
     497      heap(a1) = multli(heap(a2), heap(a3));
     498      go to nxt;
     499
     500
     501
     502                              $ binary operators on sets
     503
     504
     505$ the binary operations on sets assume that their arguments have
     506$ compatible reprs and that their first arguments can be used
     507$ destructively. the binary operations fall into two categories:
     508$ first there are the operations +, -, *, and // which can also
     509$ be normal arthmetic operations. here we call the set primitives
     510$ directly only if we know the reprs of the output and the two
     511$ inputs are the same. otherwise we will call one of the general
     512$ arithmetic routines. these routines will coerce their arguments
     513$ into matching types by calling the routine 'setup1'.
     514
     515$ other operations, such as 'with' can only apply to sets.
     516$ we have at least two opcodes for each of these quadruples,
     517$ one which calls the set primitive directly, and one which
     518$ first calls a 'setup' routine to coerce the inputs into
     519$ compatible reprs.
     520
     521$ all binary operations on sets use their first argument destructively.
     522$ where necessary they are preceed by a seperate copy quadruple.
     523
     524/case(q2_union)/        $ union
     525
     526      heap(a1) = union(heap(a2), heap(a3), yes);
     527      go to nxt;
     528
     529
     530
     531/case(q2_unset)/        $ union on unbased sets
     532
     533      heap(a1) = unset(heap(a2), heap(a3));
     534      go to nxt;
     535
     536
     537
     538/case(q2_unlset)/       $ union on local sets
     539
     540      heap(a1) = unlset(heap(a2), heap(a3));
     541      go to nxt;
     542
     543
     544
     545/case(q2_unrset)/      $ union on remote sets
     546
     547      heap(a1) = unrset(heap(a2), heap(a3));
     548      go to nxt;
     549
     550
     551
     552/case(q2_inter)/      $ general intersection
     553
     554      heap(a1) = intersect(heap(a2), heap(a3));
     555      go to nxt;
     556
     557
     558/case(q2_inset)/    $ unbased set intersection
     559
     560      heap(a1) = inset(heap(a2), heap(a3));
     561      go to nxt;
     562
     563
     564
     565/case(q2_inlset)/  $ local set intersection
     566
     567      heap(a1) = inlset(heap(a2), heap(a3));
     568      go to nxt;
     569
     570
     571
     572/case(q2_inrset)/  $ remote set intersection
     573
     574      heap(a1) = inrset(heap(a2), heap(a3));
     575      go to nxt;
     576
     577
     578
     579/case(q2_setdiff)/  $ set difference - general case
     580
     581      heap(a1) = setdiff(heap(a2), heap(a3));
     582      go to nxt;
     583
     584
     585/case(q2_difset)/  $ difference on unbased sets
     586
     587      heap(a1) = difset(heap(a2), heap(a3));
     588      go to nxt;
     589
     590
     591
     592/case(q2_diflset)/    $ difference on local sets
     593
     594      heap(a1) = diflset(heap(a2), heap(a3));
     595      go to nxt;
     596
     597
     598
     599/case(q2_difrset)/    $ difference on remote sets
     600
     601      heap(a1) = difrset(heap(a2), heap(a3));
     602      go to nxt;
     603
     604
     605
     606/case(q2_setmod)/   $ // on sets
     607
     608      heap(a1) = setmod(heap(a2), heap(a3));
     609      go to nxt;
     610
     611
     612                              $ with
     613
     614/case(q2_with)/     $ with - general case
     615
     616      heap(a1) = with(heap(a2), heap(a3));
     617
     618      go to nxt;
     619
     620
     621
     622/case(q2_withs)/    $ with on declared sets and maps
     623
     624      is_shared(a3) = yes;
     625      heap(a1) = withs(heap(a2), heap(a3), yes);
     626
     627      go to nxt;
     628
     629
     630
     631/case(q2_withus)/     $ unbased sets - equivlent to a locate
     632
     633      p  = value(a2);
     634      t3 = heap(a3);   $ may get its share bit set
     635      call locate(pos, t3, p, yes);
     636
     637      heap(a1)  = heap(a2);
     638      value(a1) = p;
     639
     640      heap(a3) = t3;
     641
     642      go to nxt;
     643
     644
     645
     646/case(q2_withls)/                  $ local sets
     647
     648      p = value(a2);
     649      .f. ls_bit(p), 1, heap(value(a3) + ls_word(p)) = yes;
     650
     651      heap(a1) = heap(a2);
     652      go to nxt;
     653
     654
     655
     656/case(q2_withrs)/               $ remote sets
     657
     658      indx = ebindx(value(a3)); $ get index of in2
     659      p = value(a2);
     660
     661      if indx > rs_maxi(p) then
     662          heap(a1) = withs(heap(a2), heap(a3), no);
     663      else
     664          rsbit(p, indx) = yes;
     665          heap(a1) = heap(a2);
     666      end if;
     667
     668      go to nxt;
     669
     670
     671
     672/case(q2_witht)/     $ with on tuples
     673
smfd  14      if is_om(a3) = no then
smfd  15
smfd  16          p    = value(a2);
smfd  17          card = nelt(p) + 1;
smfd  18
smfd  19          if card > maxindx(p) then
smfd  20              t2 = heap(a2);
smfd  21              call exptup(t2, card);
smfd  22              heap(a2) = t2; p = value_ t2;
smfd  23          end if;
smfd  24
smfd  25          is_shared(a3)  = yes;
smfd  26          tcomp(p, card) = heap(a3);
smfd  27          nelt(p)        = card;
smfd  28      end if;
smfd  29
smfd  30      heap(a1) = heap(a2);
smfd  31
smfd  32      go to nxt;
     677
     678
     679
     680/case(q2_withut)/   $ untyped tuples
     681
     682      p    = value(a2);
     683      card = nelt(p);
     684
     685      if heap(a3) ^= tcomp(p, 0) then $ a3 ^= om
     686          card = card + 1;
     687
     688          if card > maxindx(p) then
     689              t2 = heap(a2);
     690              call exptup(t2, card);
     691
     692              heap(a2) = t2;
     693              p        = value(a2);
     694          end if;
     695
     696          nelt(p)        = card;
     697          tcomp(p, card) = heap(a3);
     698      end if;
     699
     700      heap(a1) = heap(a2);
     701
     702      go to nxt;
     703
     704
     705
     706/case(q2_withm)/   $ with on maps
     707
     708$ this case handles the case
     709
     710$ a1 = a2 with >> where a2 and a3 are
     711$ n variate maps. rather than building the nested tuple and then
     712$ throwing it away immediately, we simply push x1 ... xn+1 onto
     713$ the stack and call a special version of the with routine.
     714$ here a3 is an immediate operand and gives the value of n.
     715
     716 .+dead.
     717
     718      heap(a1) = withm(heap(a2), value(a3), codea4(codep));
     719      go to nxt;
     720
     721 .-dead.
     722      call err_fatal(57);
     723 ..dead
     724
     725
     726
     727                              $ less
     728
     729
     730/case(q2_less)/                  $ general case
     731
     732      heap(a1) = less(heap(a2), heap(a3));
     733      go to nxt;
     734
     735
     736
     737/case(q2_lessls)/           $ local set
     738
     739      t2 = heap(a2); p = value_ t2;
     740      .f. ls_bit(p), 1, heap(value(a3) + ls_word(p)) = no;
     741      heap(a1) = t2;
     742
     743      go to nxt;
     744
     745
     746
     747/case(q2_lessrs)/               $ remote sets
     748
     749      indx = ebindx(value(a3)); $ get index of in2
     750      p = value(a2);
     751
     752      if indx <= rs_maxi(p) then
     753          rsbit(p, indx) = no;
     754      end if;
     755
     756      heap(a1) = heap(a2);
     757
     758      go to nxt;
     759
     760                              $ lessf
     761
     762/case(q2_lessf)/                    $ general
     763
     764      heap(a1) = lessf(heap(a2), heap(a3));
     765      go to nxt;
     766
     767
     768
     769/case(q2_lessflm)/               $ local map
     770
     771      p   = value(a2);
     772      lsw = ls_word(p);
     773
     774      heap(value(a3) + lsw) = heap(template(p) + lsw);
     775
     776      heap(a1) = heap(a2);
     777      go to nxt;
     778
     779
     780
     781/case(q2_lessfrm)/                  $ remote maps.
     782
     783      indx = ebindx(value(a3));  $ get index
     784      p = value(a2) + hl_rmap;
     785
     786      if indx <= maxindx(p) then
     787          tcomp(p, indx) = tcomp(p, 0);
     788      end if;
     789
     790      heap(a1) = heap(a2);  $ copy specifier
     791      go to nxt;
     792
     793
     794
     795/case(q2_from)/               $ from
     796
     797      t2 = heap(a2);
     798
     799      call from(t1, t2);
     800
     801      heap(a2) = t2;
     802      heap(a1) = t1;
     803
     804      go to nxt;
     805
     806
     807/case(q2_froms)/              $ from on sets
     808
     809      t2 = heap(a2);
     810
     811      call froms(t1, t2);
     812
     813      heap(a2) = t2;
     814      heap(a1) = t1;
     815
     816      go to nxt;
     817
     818
     819
     820/case(q2_fromb)/              $ fromb
     821
     822      t2 = heap(a2);
     823
     824      call fromb(t1, t2);
     825
     826      heap(a2) = t2;
     827      heap(a1) = t1;
     828
     829      go to nxt;
     830
     831
     832/case(q2_frombt)/             $ fromb on tuples
     833
     834      p    = value(a2);
     835      card = nelt(p);
     836
     837      if card > 0 then
     838          heap(a1)     = tcomp(p, 1);
     839          nelt(p)      = card - 1;
     840          is_hashok(p) = no;
     841
     842          do indx = 2 to card;
     843              tcomp(p, indx-1) = tcomp(p, indx);
     844          end do;
     845
     846          tcomp(p, card) = tcomp(p, 0);
     847
     848      else
     849          heap(a1) = tcomp(p, 0);
     850      end if;
     851
     852      go to nxt;
     853
     854
     855
     856/case(q2_frome)/              $ frome
     857
     858      t2 = heap(a2);
     859
     860      call frome(t1, t2);
     861
     862      heap(a2) = t2;
     863      heap(a1) = t1;
     864
     865      go to nxt;
     866
     867
     868/case(q2_fromet)/             $ from - tuples
     869
     870      p    = value(a2);
     871      card = nelt(p);
     872      temp = tcomp(p, 0);
     873
     874      if card > 0 then
     875          heap(a1)       = tcomp(p, card);
     876          tcomp(p, card) = temp;
     877          is_hashok(p)   = no;
     878
     879          until card = 0;
     880              card = card - 1;
     881              if (tcomp(p, card) ^= temp) quit until;
     882          end until;
     883
     884          nelt(p) = card;
     885
     886      else
     887          heap(a1) = temp;
     888      end if;
     889
     890      go to nxt;
     891
     892
     893
     894/case(q2_mini)/               $ min - short ints
     895
     896      if value(a2) <= value(a3) then
     897          heap(a1) = heap(a2);
     898      else
     899          heap(a1) = heap(a3);
     900      end if;
     901
     902      go to nxt;
     903
     904
     905
     906/case(q2_minui)/    $ .min for untyped ints
     907
     908      if heap(a2) < heap(a3) then
     909          heap(a1) = heap(a2);
     910      else
     911          heap(a1) = heap(a3);
     912      end if;
     913
     914
     915      go to nxt;
     916
     917
     918
     919/case(q2_minur)/                 $ min. for untyped reals
     920
     921      real1 = heap(a2);
     922      real2 = heap(a3);
     923
     924      if real1 <= real2 then
     925          heap(a1) = real1;
     926      else
     927          heap(a1) = real2;
     928      end if;
     929
     930      go to nxt;
     931
     932
     933
     934/case(q2_min)/                   $ min. general case
     935
     936      heap(a1) = smin(heap(a2), heap(a3));
     937      go to nxt;
     938
     939
     940
     941/case(q2_maxi)/                  $ max. for short ints
     942
     943      if value(a2) >= value(a3) then
     944          heap(a1) = heap(a2);
     945      else
     946          heap(a1) = heap(a3);
     947      end if;
     948
     949      go to nxt;
     950
     951
     952
     953/case(q2_maxui)/    $ .max for untyped ints
     954
     955      if heap(a2) > heap(a3) then
     956          heap(a1) = heap(a2);
     957      else
     958          heap(a1) = heap(a3);
     959      end if;
     960
     961      go to nxt;
     962
     963
     964
     965/case(q2_maxur)/                 $ max for untyped reals
     966
     967      real1 = heap(a2);
     968      real2 = heap(a3);
     969
     970      if real1 >= real2 then
     971          heap(a1) = real1;
     972      else
     973          heap(a1) = real2;
     974      end if;
     975
     976      go to nxt;
     977
     978
     979
     980/case(q2_max)/                   $ general max
     981
     982      heap(a1) = smax(heap(a2), heap(a3));
     983      go to nxt;
     984
     985
     986
     987/case(q2_npow)/
     988
     989      heap(a1) = npow(heap(a2), heap(a3));
     990      go to nxt;
     991
     992
     993
     994/case(q2_atan2)/
     995
     996      heap(a1) = atan2f(heap(a2), heap(a3));
     997      go to nxt;
     998
     999
    1000
    1001$ relational operators
    1002$ ---------- ---------
    1003
    1004$ these primitives branch to either pass or fail, where we generate the
    1005$ setl constants true and false.
    1006
    1007
    1008                              $ eq.
    1009
    1010
    1011
    1012/case(q2_eq1)/                   $ 1 word test
    1013
    1014      if (heap(a2) .eq. heap(a3)) go to pass;
    1015      go to fail;
    1016
    1017
    1018
    1019/case(q2_eqv)/                   $ equal values and types
    1020
    1021      if (eq(heap(a2), heap(a3))) go to pass;
    1022      go to fail;
    1023
    1024
    1025/case(q2_eq)/                    $ general test
    1026
    1027      if (eq(heap(a2), heap(a3))) go to pass;
    1028      if (ne(heap(a2), heap(a3))) go to fail;
    1029      if (equal(heap(a2), heap(a3))) go to pass;
    1030
    1031      go to fail;
    1032
    1033
    1034
    1035/case(q2_zr)/                    $ test(a2) eq 0
    1036
    1037      if (ivalue(a2) = 0) go to pass;
    1038      go to fail;
    1039
    1040
    1041/case(q2_eqom)/    $ test for om
    1042
    1043      if (is_om(a2)) go to pass;
    1044      go to fail;
    1045
    1046
    1047/case(q2_eqnl)/    $ test set = nl
    1048
    1049      if (nullp(value(a2))) go to pass;
    1050      go to fail;
    1051
    1052
    1053/case(q2_eqnult)/   $ test tuple = nult
    1054
    1055      if (nelt(value(a2)) = 0) go to pass;
    1056      go to fail;
    1057
    1058
    1059                              $ ge.
    1060
    1061/case(q2_gei)/                   $ short integer
    1062
    1063      if (ivalue(a2) >= ivalue(a3)) go to pass;
    1064      go to fail;
    1065
    1066
    1067/case(q2_geui)/   $ untyped ints
    1068
    1069      if (heap(a2) >= heap(a3)) go to pass;
    1070      go to fail;
    1071
    1072
    1073/case(q2_geur)/  $ untyped reals
    1074
    1075      real1 = heap(a2);   real2 = heap(a3);
    1076
    1077      if (real1 >= real2) go to pass;
    1078      go to fail;
    1079
    1080
    1081/case(q2_ge)/                    $ general
    1082
    1083      if (otype(a2) = t_int & otype(a3) = t_int) go to case(q2_gei);
    1084
mjsa  24      if (lt(heap(a2), heap(a3))) go to fail;
mjsa  25      go to pass;
    1087
    1088
    1089/case(q2_incs)/                   $ incs.
    1090
    1091      if (incs(heap(a2), heap(a3))) go to pass;
    1092      go to fail;
    1093
    1094
    1095/case(q2_in)/                 $ in - general case
    1096
    1097      if (member(heap(a2), heap(a3))) go to pass;
    1098      go to fail;
    1099
    1100
    1101
    1102/case(q2_ins)/       $ set or map
    1103
    1104      if (memset(heap(a2), heap(a3))) go to pass;
    1105      go to fail;
    1106
    1107
    1108
    1109/case(q2_inu)/    $ unbased set
    1110
    1111      call locate(pos, heap(a2), value(a3), no);  $ locate but dont add
    1112      if (loc_found) go to pass;
    1113      go to fail;
    1114
    1115
    1116
    1117/case(q2_inl)/                   $ local subset
    1118
    1119      p = value(a3);  $ pointer to local set
    1120
    1121      if (.f. ls_bit(p), 1, heap(value(a2)+ls_word(p))) go to pass;
    1122      go to fail;
    1123
    1124
    1125
    1126/case(q2_inr)/                   $ remote subset
    1127
    1128      indx = ebindx(value(a2));  $ base element block index
    1129      p    = value(a3);          $ pointer to bit string
    1130
    1131      if (indx > rs_maxi(p)) go to fail;
    1132
    1133      if (rsbit(p, indx)) go to pass;
    1134      go to fail;
    1135
    1136
    1137
    1138/case(q2_lti)/                   $ short ints
    1139
    1140      if (ivalue(a2) < ivalue(a3)) go to pass;
    1141      go to fail;
    1142
    1143
    1144/case(q2_ltui)/  $ untyped ints
    1145
    1146      if (heap(a2) < heap(a3)) go to pass;
    1147      go to fail;
    1148
    1149
    1150
    1151/case(q2_ltur)/   $ untyped reals
    1152
    1153      real1 = heap(a2);   real2 = heap(a3);
    1154
    1155      if (real1 < real2) go to pass;
    1156      go to fail;
    1157
    1158
    1159/case(q2_lt)/                    $ general case
    1160
    1161      if (otype(a2) = t_int & otype(a3) = t_int) go to case(q2_lti);
    1162
    1163      if (lt(heap(a2), heap(a3))) go to pass;
    1164      go to fail;
    1165
    1166
    1167/case(q2_ne1)/   $ 1 word test
    1168
    1169      if (heap(a2) ^= heap(a3)) go to pass;
    1170      go to fail;
    1171
    1172
    1173/case(q2_nev)/                   $ test values and types
    1174
    1175      if (^ eq(heap(a2), heap(a3))) go to pass;
    1176      go to fail;
    1177
    1178
    1179/case(q2_ne)/                    $ general case
    1180
    1181      if (eq(heap(a2), heap(a3))) go to fail;
    1182      if (ne(heap(a2), heap(a3))) go to pass;
    1183      if (equal(heap(a2), heap(a3))) go to fail;
    1184      go to pass;
    1185
    1186
    1187/case(q2_nz)/   $ test for nonzero
    1188
    1189      if (ivalue(a2) ^= 0) go to pass;
    1190      go to fail;
    1191
    1192
    1193/case(q2_neom)/  $ test for om
    1194
    1195      if (^ is_om(a2)) go to pass;
    1196      go to fail;
    1197
    1198
    1199/case(q2_nenl)/   $ test set ^= nl
    1200
    1201      if (^ nullp(value(a2))) go to pass;
    1202      go to fail;
    1203
    1204
    1205/case(q2_nenult)/  $ test tuple ^= nult
    1206
    1207      if (nelt(value(a2)) ^= 0) go to pass;
    1208      go to fail;
    1209
    1210
    1211/case(q2_nincs)/              $ a1 := not (a2 incs a3)
    1212
    1213      if ( ^ incs(heap(a2), heap(a3))) go to pass;
    1214      go to fail;
    1215
    1216
    1217
    1218/case(q2_nin)/                        $ general case - offline call
    1219
    1220      if (member(heap(a2), heap(a3))) go to fail;
    1221      go to pass;
    1222
    1223
    1224
    1225/case(q2_nins)/                   $ set or map
    1226
    1227      if (memset(heap(a2),heap(a3))) go to fail;
    1228      go to pass;
    1229
    1230
    1231
    1232/case(q2_ninu)/                   $ local subset
    1233
    1234      call locate(pos,heap(a2),value(a3),no); $ locate but dont add
    1235      if (loc_found) go to fail;
    1236      go to pass;
    1237
    1238
    1239
    1240/case(q2_ninl)/                   $ local subset
    1241
    1242      p = value(a3);  $ pointer to local set
    1243
    1244      if (.f. ls_bit(p), 1, heap(value(a2)+ls_word(p))) go to fail;
    1245      go to pass;
    1246
    1247
    1248
    1249/case(q2_ninr)/                   $ remote subset
    1250
    1251      indx = ebindx(value(a2));  $ base element block index
    1252      p    = value(a3);          $ pointer to bit string
    1253
    1254      if (indx > rs_maxi(p)) go to pass;
    1255      if (rsbit(p, indx)) go to fail;
    1256      go to pass;
    1257
    1258
    1259
    1260/pass/          $ return true.
    1261
    1262      heap(a1) = heap(s_true);   go to nxt;
    1263
    1264
    1265/fail/          $ return false.
    1266
    1267      heap(a1) = heap(s_false);   go to nxt;
    1268
    1269
    1270/nxt/
    1271
    1272      codep = codep + inst_nw;
    1273
    1274
    1275      end subr intrp1;
       1 .=member intrp2
       2      subr intrp2;
       3
       4$ this routine contains the second part of the interpreter.  at
       5$ this point the current quadruple has been unpacked, and we are
       6$ ready to jump on its opcode.
       7
       8
       9      size proc(sds_sz),     $ name of current routine
      10           stmt(ps);         $ current statement
      11
      12      access nsintp;
      13
      14      size even(1);
      15      size isamap(1);
      16      size arb(hs), arbs(hs);
      17      size dom(hs),
      18           range(hs),
      19           pow(hs),
      20           getnelt(hs),
      21           sabs(hs),
      22           schar(hs),
      23           ceil(hs),
      24           floor(hs),
      25           sfix(hs),
      26           sfloat(hs),
      27           srand(hs),
      28           relf(hs),
      29           sign(hs),
mjsa  26           umin(hs), uminli(hs),
      31           str(hs),
      32           valr(hs);
      33      size nullset(hs),  $ functions called
      34           nulltup(hs),
      35           sdate(hs),
      36           endop(hs),
      37           subst(hs),
      38           send(hs),
      39           ssubst(hs), ssbsts(hs),
      40           setform(hs),
      41           setf1(hs),
      42           tupform(hs),
      43           convert(hs),
      44           copy1(hs);
      45
      46
      47$ begin execution
      48
      49 .+st  init_time(st_lib);      $ start measuring library time
      50
      51      go to case(op) in q2_not to q2_ssubst;
      52
      53
      54$ section 3 - unary operators
      55$ ------- - - ----- ---------
      56
      57
      58/case(q2_not)/                $ not - general case
      59
      60      if (eq(heap(a2), heap(s_false))) go to pass;
      61      if (eq(heap(a2), heap(s_true)))  go to fail;
      62
      63      call err_misc(51);   heap(a1) = err_val(f_gen);
      64
      65      go to nxt;
      66
      67
      68/case(q2_even)/               $ even - general case
      69
      70      if (otype(a2) = t_int) go to case(q2_eveni);
      71
      72      if (even(heap(a2))) go to pass;
      73      go to fail;
      74
      75
      76/case(q2_eveni)/              $ even - integer case
      77
      78 .+s10  if (^ .f. 1, 1, heap(a2)) go to pass;
      79 .+s20  if (^ .f. 1, 1, heap(a2)) go to pass;
suna  32 .+r32  if (^ .f. 3, 1, heap(a2)) go to pass;
      83 .+s66  if (^ .f. 1, 1, heap(a2)) go to pass;
      84
      85      go to fail;
      86
      87
      88/case(q2_evenui)/             $ even - untyped integers
      89
      90 .+s10 if ( ( .f. 1, 1, heap(a2)) = ( heap(a2) < 0 ) ) go to pass;
suna  33 .+r32 if ( ( .f. 1, 1, heap(a2)) = ( heap(a2) < 0 ) ) go to pass;
      94 .+s66 if (^ .f. 1, 1, heap(a2)) go to pass;
      95      go to fail;
      96
      97
      98/case(q2_odd)/                $ odd - general case
      99
     100      if (otype(a2) = t_int) go to case(q2_oddi);
     101
     102      if (^ even(heap(a2))) go to pass;
     103      go to fail;
     104
     105
     106/case(q2_oddi)/               $ odd - typed integers
     107
     108 .+s10  if (.f. 1, 1, heap(a2)) go to pass;
     109 .+s20  if (.f. 1, 1, heap(a2)) go to pass;
suna  34 .+r32  if (.f. 3, 1, heap(a2)) go to pass;
     113 .+s66  if (.f. 1, 1, heap(a2)) go to pass;
     114
     115      go to fail;
     116
     117
     118/case(q2_oddui)/              $ odd - untyped integers
     119
     120 .+s10 if ( ( .f. 1, 1, heap(a2)) = ( heap(a2) >= 0 ) ) go to pass;
suna  35 .+r32 if ( ( .f. 1, 1, heap(a2)) = ( heap(a2) >= 0 ) ) go to pass;
suna  36
     124 .+s66 if (.f. 1, 1, heap(a2)) go to pass;
     125      go to fail;
     126
     127
     128 /case(q2_isint)/
     129      size istype(1);
     130      t1 = istype(ist_int, heap(a2));
     131      if (t1) go to pass;
     132      go to fail;
     133
     134 /case(q2_isreal)/
     135      t1 = istype(ist_rea, heap(a2));
     136      if (t1) go to pass;
     137      go to fail;
     138
     139 /case(q2_isstr)/
     140      t1 = istype(ist_str, heap(a2));
     141      if (t1) go to pass;
     142      go to fail;
     143
     144 /case(q2_isbool)/
     145      t1 = istype(ist_boo, heap(a2));
     146      if (t1) go to pass;
     147      go to fail;
     148
     149 /case(q2_isatom)/
     150      t1 = istype(ist_ato, heap(a2));
     151      if (t1) go to pass;
     152      go to fail;
     153
     154 /case(q2_istup)/
     155
     156      t1 = istype(ist_tup, heap(a2));
     157      if (t1) go to pass;
     158      go to fail;
     159
     160 /case(q2_isset)/
     161
     162      t1 = istype(ist_set, heap(a2));
     163      if (t1) go to pass;
     164      go to fail;
     165
     166 /case(q2_ismap)/
     167
     168      t1 = istype(ist_map, heap(a2));
     169      if (t1) go to pass;
     170      go to fail;
     171
     172
     173
     174
     175
     176/pass/          $ return true.
     177
     178      heap(a1) = heap(s_true);   go to nxt;
     179
     180
     181/fail/          $ return false.
     182
     183      heap(a1) = heap(s_false);   go to nxt;
     184
     185
     186/case(q2_abs)/                $ abs - general case
     187
     188      heap(a1) = sabs(heap(a2));
     189      go to nxt;
     190
     191
     192/case(q2_absi)/               $ abs - short integers
     193
     194      build_spec(heap(a1), t_int, iabs(ivalue(a2)));
     195      go to nxt;
     196
     197
     198/case(q2_absui)/              $ abs - untyped integers
     199
     200      heap(a1) = iabs(heap(a2));
     201      go to nxt;
     202
     203
     204/case(q2_absur)/              $ abs - untyped reals
     205
     206      real1 = heap(a2);
     207
     208      heap(a1) = abs(real1);
     209      go to nxt;
     210
     211
     212/case(q2_char)/
     213
     214      heap(a1) = schar(heap(a2));
     215      go to nxt;
     216
     217
     218/case(q2_ceil)/               $ ceil - general case
     219
     220      heap(a1) = ceil(heap(a2));
     221      go to nxt;
     222
     223
     224/case(q2_ceilur)/             $ ceil - untyped reals
     225
     226      real2 = heap(a2);
     227      t1 = ifix(real2);   if (float(t1) < real2) t1 = t1 + 1;
     228      heap(a1) = t1;
     229
     230      go to nxt;
     231
     232
     233/case(q2_floor)/              $ floor - general case
     234
     235      heap(a1) = floor(heap(a2));
     236      go to nxt;
     237
     238
     239/case(q2_floorur)/            $ floor - untyped reals
     240
     241      real2 = heap(a2);
     242      t1 = ifix(real2);   if (float(t1) > real2) t1 = t1 - 1;
     243      heap(a1) = t1;
     244
     245      go to nxt;
     246
     247
     248/case(q2_fix)/                $ fix - general case
     249
     250      heap(a1) = sfix(heap(a2));
     251      go to nxt;
     252
     253
     254/case(q2_fixur)/              $ fix - untyped reals
     255
     256      real2 = heap(a2);   heap(a1) = ifix(real2);
     257      go to nxt;
     258
     259
     260/case(q2_float)/              $ float - general case
     261
     262      heap(a1) = sfloat(heap(a2));
     263      go to nxt;
     264
     265
     266/case(q2_floatui)/            $ float - untyped integer
     267
     268      heap(a1) = float(heap(a2));
     269      go to nxt;
     270
     271
     272/case(q2_arb)/   $ arb
     273
     274      heap(a1) = arb(heap(a2));
     275      go to nxt;
     276
     277
     278/case(q2_arbs)/    $ arb on sets
     279
     280      heap(a1) = arbs(heap(a2));
     281      go to nxt;
     282
     283
     284
     285/case(q2_arbt)/     $ tuples
     286
     287      p = value(a2);
     288
     289      is_shared_ tcomp(p, 1) = yes;
     290      heap(a1) = tcomp(p, 1);
     291
     292      go to nxt;
     293
     294
     295
     296/case(q2_arbut)/   $ untyped tuples
     297
     298      p = value(a2);
     299
     300      heap(a1) = tcomp(p, 1);
     301
     302      go to nxt;
     303
     304
     305
     306/case(q2_asrt)/    $ test assertion
     307
     308      if eq(heap(a1), heap(s_false)) then   $ failed
     309          if (assert_mode ^= assert_off) call err_misc(9);
     310
     311      elseif ^ eq(heap(a1), heap(s_true)) then
     312          call err_misc(52);
     313
     314      elseif assert_mode = assert_full then
     315          call find_stmt(proc, stmt, codep);
     316
     317          put, 'assertion passed at statement ': stmt, i,
     318               ' in procedure ': proc, a, skip;
     319      end if;
     320
     321      go to nxt;
smfb  69
smfb  70
smfb  71/case(q2_ifasrt)/             $ check if assertions are evaluated
smfb  72
smfb  73      if assert_mode = assert_off then
smfb  74          codep = a1;
smfb  75          return;
smfb  76      end if;
smfb  77
smfb  78      go to nxt;
     322
     323
     324/case(q2_val)/                $ .val
     325
     326      heap(a1) = valr(heap(a2));
     327      go to nxt;
     328
     329
     330
     331/case(q2_domain)/   $ dom
     332
     333      heap(a1) = dom(heap(a2), a3);
     334      go to nxt;
     335
     336
     337/case(q2_range)/   $ range
     338
     339      heap(a1) = range(heap(a2), a3);
     340      go to nxt;
     341
     342
     343/case(q2_neltst)/                $ nelt on sets and tuples
     344
     345      ok_nelt(heap(a2));   $ update nelt.
     346      build_spec(heap(a1), t_int, nelt(value(a2)));
     347      go to nxt;
     348
     349
     350/case(q2_neltok)/  $ sets and tuples, nelt valid
     351
     352      build_spec(heap(a1), t_int, nelt(value(a2)));
     353      go to nxt;
     354
     355
     356
     357/case(q2_neltic)/      $ nelt on indirect chars
     358
stra  29      $ fall through to q2_neltc case below.
     363
     364/case(q2_neltc)/                 $ nelt - short chars.
     365
stra  30      temp = 0;  $ clear share bit, is_om bit, and set type to t_int
stra  31
stra  32      if otype(a2) = t_istring then
stra  33          ivalue_ temp = ss_len(value(a2));
stra  34      elseif otype(a2) = t_string then
stra  35          ivalue_ temp = sc_nchars(a2);
stra  36      else
stra  37          temp = spec_om;
stra  38      end if;
stra  39
stra  40      heap(a1) = temp;
stra  41
     368      go to nxt;
     369
     370
     371
     372/case(q2_nelt)/                  $ nelt - general
     373
     374      heap(a1) = getnelt(heap(a2));
     375      go to nxt;
     376
     377
     378
     379/case(q2_pow)/   $ pow
     380
     381      heap(a1) = pow(heap(a2));
     382      go to nxt;
     383
     384
     385
     386/case(q2_rand)/   $ random
     387
     388      heap(a1) = srand(heap(a2));
     389      go to nxt;
     390
     391
     392/case(q2_sin)/
     393
     394      heap(a1) = relf(relf_sin, heap(a2));
     395      go to nxt;
     396
     397
     398/case(q2_cos)/
     399
     400      heap(a1) = relf(relf_cos, heap(a2));
     401      go to nxt;
     402
     403
     404/case(q2_tan)/
     405
     406      heap(a1) = relf(relf_tan, heap(a2));
     407      go to nxt;
     408
     409
     410/case(q2_arcsin)/
     411
     412      heap(a1) = relf(relf_asin, heap(a2));
     413      go to nxt;
     414
     415
     416/case(q2_arccos)/
     417
     418      heap(a1) = relf(relf_acos, heap(a2));
     419      go to nxt;
     420
     421
     422/case(q2_arctan)/
     423
     424      heap(a1) = relf(relf_atan, heap(a2));
     425      go to nxt;
     426
     427
     428/case(q2_tanh)/
     429
     430      heap(a1) = relf(relf_tanh, heap(a2));
     431      go to nxt;
     432
     433
     434/case(q2_sqrt)/
     435
     436      heap(a1) = relf(relf_sqrt, heap(a2));
     437      go to nxt;
     438
     439
     440/case(q2_expf)/
     441
     442      heap(a1) = relf(relf_exp, heap(a2));
     443      go to nxt;
     444
     445
     446/case(q2_log)/
     447
     448      heap(a1) = relf(relf_log, heap(a2));
     449      go to nxt;
     450
     451
     452/case(q2_type)/               $ type
     453
     454      $ n.b. the boolean constants 'true' and 'false' are the two
     455      $      blank atoms '0' and 'maxsi', resp.
     456
     457      temp = heap(a2);   deref(temp);   temp = otype_ temp;
     458
     459      if temp = t_atom & (ivalue(a2)=0 ! ivalue(a2)=maxsi) then
     460          heap(a1) = heap(s_types(t_max+1));
     461      else
     462          heap(a1) = heap(s_types(temp));
     463      end if;
     464
     465      go to nxt;
     466
     467
     468/case(q2_umin)/               $ unary minus - general case
     469
     470       heap(a1) = umin(heap(a2));
     471       go to nxt;
     472
     473
     474/case(q2_umini)/              $ unary minus - typed integer case
     475
mjsa  27      heap(a1) = uminli(heap(a2));
     479
     480      go to nxt;
     481
     482
     483/case(q2_uminui)/             $ unary minus - untyped integer case
     484
     485      heap(a1) = - heap(a2);
     486      go to nxt;
     487
     488
     489
     490/case(q2_uminur)/             $ unary minus - untyped real case
     491
     492      real1 =heap(a2);
     493      heap(a1) = -real1;
     494      go to nxt;
     495
     496
     497
     498/case(q2_str)/    $ integer to string conversion
     499
     500      heap(a1) = str(heap(a2));
     501      go to nxt;
     502
     503
     504/case(q2_sign)/    $ .sign
     505
     506      heap(a1) = sign(heap(a2));
     507      go to nxt;
     508
     509/case(q2_end)/       $ s(i..)
     510
     511      heap(a1) = endop(heap(a2), heap(a3));
     512      go to nxt;
     513
     514
     515/case(q2_subst)/    $ s(i..j)
     516
     517      a4 = codea1(codep + inst_nw);  $ get fourth argument
     518
     519      heap(a1) = subst(heap(a2), heap(a3), heap(a4));
     520
     521      codep = codep + 2*inst_nw;
     522      return;
     523
     524
     525/case(q2_newat1)/      $ newat - simple case
     526
     527$ this version of newat generates blank atoms with no extra fields for
     528$ basing information. we only allow short atoms to be used for this
     529$ purpose. the newat operation is handled by the newat1 macro.
     530
     531      newat1(heap(a1));
     532      go to nxt;
     533
     534
     535
     536/case(q2_newat2)/   $ newat - based case
     537
     538$ allocate long atom with extra fields. a2 is a pointer to the sample
     539$ value.
     540
     541      pos  = value(a2);       $ pointer to sample value
     542      temp = la_nwords(pos);  $ length of block
     543
     544      get_heap(temp, p);
     545
     546      do j = 0 to temp-1;
     547          heap(p+j) = heap(pos+j);
     548      end do;
     549
     550$ set la_value to 'next_latom', then build specifier.
     551      la_value(p) = next_latom;
     552      next_latom  = next_latom + 1;
     553
     554      build_spec(temp, t_latom, p); heap(a1) = temp;
     555
     556      go to nxt;
     557
     558
     559/case(q2_time)/   $ time function
     560
     561      call letime(temp);
     562      temp = temp - entry_time;   put_intval(temp, t1);
     563      heap(a1) = t1;
     564
     565      go to nxt;
     566
     567
     568/case(q2_date)/   $ date function
     569
     570      heap(a1) = sdate(0);
     571      go to nxt;
     572
     573/case(q2_na)/     $ number of arguments for current procedure
     574
     575      build_spec(heap(a1), t_int, cur_na);
     576      go to nxt;
     577
     578
     579
     580$ set formers
     581
     582$ the three setformers have:
     583
     584$ a1:    pointer to result
     585$ a2:    form of result
     586$ a3:    pointer to short int giving number of elements
     587
     588$ note that we must always reset savet after these instructions since
     589$ the setformer pops the stack.
     590
     591
     592/case(q2_set1)/      $ set or map former
     593
     594$ build set or map, depending on whether elements are all
     595$ pairs.
     596
     597      heap(a1) = setf1(value(a3));
     598
     599      savet = t;
     600      go to nxt;
     601
     602/case(q2_set2)/    $ elements are all proper type
     603      heap(a1) = setform(a2, value(a3));
     604
     605      savet = t;
     606      go to nxt;
     607
     608
     609
     610
     611
     612
     613
     614$ tuple formers
     615
     616$ these have arguments just like the set formers.
     617
     618/case(q2_tup1)/     $ elements are proper type
     619
     620      heap(a1) = tupform(a2, value(a3));
     621
     622      savet = t;
     623      go to nxt;
     624
     625
     626/case(q2_tup2)/    $ mixed tuple, elements require conversion
     627
     628      p = value(a3);  $ number of elements
     629
     630      do j = 1 to p;
     631          stack_arg(j, p) = convert(stack_arg(j, p), a2);
     632      end do;
     633
     634      heap(a1) = tupform(a2, p);
     635
     636      savet = t;
     637
     638      go to nxt;
     639
     640
     641
     642
     643
     644                             $ section 5 - mappings
     645
     646$ these operations have the form a1 = a2(a3).
     647
     648                             $ of - f(x)
     649
     650/case(q2_of)/   $ general case
     651
     652
     653      t2 = heap(a2);  $ may be converted to a map
     654      call of(t1, t2, heap(a3));
     655
     656      heap(a2) = t2;
     657      heap(a1) = t1;
     658
     659      go to nxt;
     660
     661
     662
     663/case(q2_ofcs)/                 $ short character string
     664
stra  42      $ fall through to q2_ofcl case below.
     683
     684/case(q2_ofcl)/                 $ long chars. index is short int
     685
     686      indx = otvalue(a3);     $ value of index
stra  43      t2 = heap(a2);
stra  44
stra  45      if otype_ t2 = t_istring then
stra  46          ss = value_ t2;
stra  47          if 0 < indx & indx <= ss_len(ss) then
stra  48              temp = spec_char;  $ one-character template
stra  49              scchar(temp, 1) = icchar(ss, indx);
stra  50          else
stra  51              temp = heap(ft_samp(f_sstring));
stra  52          end if;
stra  53      elseif otype_ t2 = t_string then
stra  54          if 0 < indx & indx <= sc_nchars_ t2 then
stra  55              temp = spec_char;  $ one-character template
stra  56              scchar(temp, 1) = scchar(t2, 1);
stra  57          else
stra  58              temp = heap(ft_samp(f_sstring));
stra  59          end if;
stra  60      end if;
stra  61
stra  62      heap(a1) = temp;
     696
     697      go to nxt;
     698
     699
     700
     701$ tuple cases
     702
     703/case(q2_oftoks)/             $ index in range, set share bit
     704
     705      is_shared_ tcomp(value(a2), ivalue(a3)) = yes;
     706
     707
     708
     709/case(q2_oftok)/              $ index is in range.
     710
     711      heap(a1) = tcomp(value(a2), ivalue(a3));
     712
     713      go to nxt;
     714
     715
     716
     717/case(q2_oft)/                $ index is short integer
     718
     719      p    = value(a2);   $ pointer to tuple
     720
smfb  79      indx = otvalue(a3);     $ index
     722      if (indx > nelt(p)) indx = 0;
     723
     724      heap(a1) = tcomp(p, indx);
     725
     726      go to nxt;
     727
     728
     729
     730/case(q2_ofts)/               $ as above, but set share bit
     731
     732      p    = value(a2);
     733
smfb  80      indx = otvalue(a3);     $ index
     735      if (indx > nelt(p)) indx = 0;
     736
     737      is_shared_ tcomp(p, indx) = yes;
     738      heap(a1) = tcomp(p, indx);
     739
     740      go to nxt;
     741
     742
     743
     744$ maps
     745
     746/case(q2_ofusms)/     $ unbased smap - set share bit
     747
     748      call locate(pos, heap(a3), value(a2), no);
     749      is_shared_ ebimag(pos) = yes;
     750      heap(a1) = ebimag(pos);
     751
     752      go to nxt;
     753
     754
     755
     756/case(q2_ofusm)/     $ unbased smap
     757
     758      call locate(pos, heap(a3), value(a2), no);
     759      heap(a1) = ebimag(pos);
     760      go to nxt;
     761
     762
     763
     764/case(q2_ofums)/    $ unbased, possibly multivalued map. set share bit
     765
     766      call locate(pos, heap(a3), value(a2), no);
     767      is_shared_ ebimag(pos) = yes;
     768      heap(a1) = ebimag(pos);
     769
     770      if (is_multi(a1)) call err_misc(10);
     771
     772      go to nxt;
     773
     774
     775
     776/case(q2_ofum)/     $ unbased map
     777
     778      call locate(pos, heap(a3), value(a2), no);
     779      heap(a1) = ebimag(pos);
     780
     781      if (is_multi(a1)) call err_misc(11);
     782
     783      go to nxt;
     784
     785
     786
     787/case(q2_oflsms)/       $ local smap - set share bit
     788
     789      is_shared(value(a3) + ls_word(value(a2))) = yes;
     790
     791
     792
     793/case(q2_oflsm)/                $ local smap
     794
     795      heap(a1) = heap(value(a3)+ls_word(value(a2)));
     796      go to nxt;
     797
     798
     799
     800/case(q2_oflms)/       $ local map - set share bit
     801
     802      is_shared(value(a3) + ls_word(value(a2))) = yes;
     803
     804
     805
     806/case(q2_oflm)/   $ local map, possibly multivalued
     807
     808      heap(a1) = heap(value(a3)+ls_word(value(a2)));
     809
     810      if (is_multi(a1)) call err_misc(12);
     811
     812      go to nxt;
     813
     814
     815
     816/case(q2_ofrsm)/                $ remote smap
     817
     818      indx = ebindx(value(a3));  $ get base index
     819      p = value(a2) + hl_rmap;
     820
     821      if (indx > maxindx(p)) indx = 0;  $ force index to be in range
     822      heap(a1) = tcomp(p, indx);
     823
     824      go to nxt;
     825
     826
     827
     828/case(q2_ofrsms)/    $ as above, but set share bit
     829
     830      indx = ebindx(value(a3));
     831      p = value(a2) + hl_rmap;
     832
     833      if (indx > maxindx(p)) indx = 0;
     834
     835      is_shared_ tcomp(p, indx) = yes;
     836      heap(a1) = tcomp(p, indx);
     837
     838      go to nxt;
     839
     840
     841
     842/case(q2_ofrm)/       $ remote map
     843
     844      indx = ebindx(value(a3));
     845      p = value(a2) + hl_rmap;
     846
     847      if (indx > maxindx(p)) indx = 0;
     848
     849      heap(a1) = tcomp(p, indx);
     850
     851      if (is_multi(a1)) call err_misc(13);
     852
     853      go to nxt;
     854
     855
     856
     857/case(q2_ofrms)/       $ same, but set share bit
     858
     859      indx = ebindx(value(a3));
     860      p = value(a2) + hl_rmap;
     861
     862      if (indx > maxindx(p)) indx = 0;
     863
     864      is_shared_ tcomp(p, indx) = yes;
     865      heap(a1) = tcomp(p, indx);
     866
     867      if (is_multi(a1)) call err_misc(14);
     868
     869      go to nxt;
     870
     871
     872
     873$ ofa - y := f<>
     874
     875/case(q2_ofa)/        $ general case
     876
     877      t2 = heap(a2);  $ may be modified
     878      call ofa(t1, t2, heap(a3));
     879
     880      heap(a2) = t2;
     881      heap(a1) = t1;
     882
     883      go to nxt;
     884
     885
     886
     887/case(q2_ofaumms)/     $ unbased mmap - set share bit
     888
     889      call locate(pos, heap(a3), value(a2), no);
     890      is_shared_ ebimag(pos) = yes;
     891      heap(a1) = ebimag(pos);
     892      is_multi(a1) = no;
     893
     894      go to nxt;
     895
     896
     897
     898/case(q2_ofaumm)/   $ unbased mmap
     899
     900      call locate(pos, heap(a3), value(a2), no);
     901      heap(a1) = ebimag(pos);
     902      is_multi(a1) = no;
     903      go to nxt;
     904
     905
     906
     907/case(q2_ofalmms)/    $ local mmap - set share bit
     908
     909      is_shared(value(a3) + ls_word(value(a2))) = yes;
     910
     911
     912
     913/case(q2_ofalmm)/     $ local mmap
     914
     915      heap(a1) = heap(value(a3) + ls_word(value(a2)));
     916      is_multi(a1) = no;
     917      go to nxt;
     918
     919
     920
     921/case(q2_ofarmm)/     $ remote mmap
     922
     923      indx = ebindx(value(a3));
     924      p = value(a2) + hl_rmap;
     925
     926      if (indx > maxindx(p)) indx = 0;
     927
     928      heap(a1) = tcomp(p, indx);
     929      is_multi(a1) = no;
     930
     931      go to nxt;
     932
     933
     934
     935/case(q2_ofarmms)/     $ as above, but set share bit
     936
     937      indx = ebindx(value(a3));
     938      p = value(a2) + hl_rmap;
     939
     940      if (indx > maxindx(p)) indx = 0;
     941
     942      is_shared_ tcomp(p, indx) = yes;
     943      heap(a1) = tcomp(p, indx);
     944
     945      is_multi(a1) = no;
     946
     947      go to nxt;
     948
     949
     950
     951                             $ section 8 - assignments
     952
     953$ these have the form a1 = a2.
     954
     955/case(q2_asn)/                  $ simple case
     956
     957      heap(a1) = heap(a2);
     958      go to nxt;
     959
     960
     961
     962/case(q2_asnsb)/                $ set share bit
     963
     964      is_shared(a2) = yes;
     965      heap(a1) = heap(a2);
     966      go to nxt;
     967
     968
     969
     970/case(q2_asnnl)/ $ a2 is form and a3 is size
     971
     972      heap(a1) = nullset(a2, a3);
     973      go to nxt;
     974
     975
     976
     977/case(q2_asnnult)/   $ a1 = nult. similar to the above
     978
     979      heap(a1) = nulltup(a2, a3);
     980      go to nxt;
     981
     982
     983
     984
     985
     986/case(q2_push)/                 $ stack push
     987
     988$ a2 is the number of items to be pushed. a1 is the first item to
     989$ be pushed; the remaining items to be pushed are in a1 of successive
     990$ quadruples. note that whenever the interpreter adjusts the stack,
     991$ it must save the new value of t.
     992
     993      get_stack(a2);
     994      savet = t;
     995
     996      do j = 1 to a2;
     997          is_shared(codea1(codep + (j-1) * inst_nw)) = yes;
     998          heap(t+a2-j) = heap(codea1(codep + (j-1) * inst_nw));
     999      end do;
    1000
    1001      codep = codep + a2 * inst_nw;
    1002      return;
    1003
    1004
    1005
    1006/case(q2_pop)/      $ stack pop
    1007
    1008$ this is the reverse of the above.
    1009
    1010      do j = 1 to a2;
    1011          heap(codea1(codep+ (j-1) * inst_nw)) = heap(t+a2-j);
    1012      end do;
    1013
    1014      free_stack(a2);
    1015      savet = t;
    1016
    1017      codep = codep + a2 * inst_nw;
    1018      return;
    1019
    1020
    1021
    1022
    1023/case(q2_push1)/      $ push a1
    1024
    1025      is_shared(a1) = yes;
    1026
    1027      push1(heap(a1));
    1028      savet = t;
    1029
    1030      go to nxt;
    1031
    1032
    1033/case(q2_push1u)/   $ push untyped integer
    1034
    1035      push1(heap(a1));
    1036
    1037      build_spec(temp, t_skip, 2);
    1038      push1(temp);
    1039
    1040      savet = t;
    1041
    1042      go to nxt;
    1043
    1044
    1045
    1046/case(q2_pop1)/    $ pop a1
    1047
    1048      pop1(heap(a1));
    1049      savet = t;
    1050
    1051      go to nxt;
    1052
    1053
    1054
    1055/case(q2_free)/      $ free stack space
    1056
    1057$ this operation is used after passing arguments to the library
    1058$ through the stack. it frees value(a1) locations.
    1059      free_stack(value(a1));
    1060      savet = t;
    1061      go to nxt;
    1062
    1063/case(q2_free1)/   $ free 1 location
    1064
    1065      free_stack(1);
    1066      savet = t;
    1067
    1068      go to nxt;
    1069
    1070
    1071
    1072
    1073                             $ section 7 - sinister assignments
    1074
    1075$ these have the form a1(a2) = a3.
    1076
    1077                             $ sof  f(x) = y
    1078
    1079
    1080
    1081/case(q2_sof)/                  $ general case
    1082
    1083      t1 = heap(a1);
    1084
    1085      call sof(t1, heap(a2), heap(a3));
    1086
    1087      heap(a1) = t1;
    1088
    1089      go to nxt;
    1090
    1091
    1092
    1093
    1094/case(q2_sofcs)/ $ short chars inputs as above, but y is a 1 character s
    1095
stra  63      $ fall through to q2_sofcl case below.
    1114
    1115/case(q2_sofcl)/                $ long chars. inputs as above
    1116
stra  64      t1 = heap(a1);  $ get specifier for left-hand side
stra  65      t2 = heap(a2);  $ get specifier for index
stra  66      t3 = heap(a3);  $ get specifier for right-hand side
stra  67      indx = ivalue_ t2;  $ get value of index
    1118
strb   8      until 1;  $ exit when done.
strb   9          until 2;  $ exit when error.
strb  10              if (indx < 1) quit until 2;
strb  11              until 3;  $ exit when character in temp.
strb  12                  until 4;  $ exit if library call.
strb  13                      until 5;  $ exit if t3 is not a short string.
strb  14                          if (otype_ t3 ^= t_string) quit until 5;
strb  15                          if (sc_nchars_ t3 ^= 1) quit until 4;
strb  16                          temp = scchar(t3, 1);  $ get character.
strb  17                          quit until 3;
strb  18                      end until 5;
strb  19                      if (otype_ t3 ^= t_istring) quit until 2;
strb  20                      ss = value_ t3;  $ get pointer to string block.
strb  21                      if (ss_len(ss) ^= 1) quit until 4;
strb  22                      temp = icchar(ss, 1);
strb  23                      quit until 3;
strb  24                  end until 4;
strb  25                  t1 = ssubst(t1, t2, t2, t3);
strb  26                  quit until 1;
strb  27              end until 3;
strb  28              until 3;  $ exit if t1 is not short string.
strb  29                  if (otype_ t1 ^= t_string) quit until 3;
strb  30                  if (indx > sc_nchars_ t1) quit until 2;
strb  31                  t1 = spec_char; scchar(t1, 1) = temp;
strb  32                  quit until 1;
strb  33              end until 3;
strb  34              if (otype_ t1 ^= t_istring) quit until 2;
strb  35              ss = value_ t1;
strb  36              if (indx > ss_len(ss)) quit until 2;
strb  37              icchar(ss, indx) = temp;
strb  38              quit until 1;
strb  39          end until 2;
strb  40          t1 = err_val(f_sstring);
strb  41      end until 1;
stra  96
stra  97      heap(a1) = t1;
    1128
    1129      go to nxt;
    1130
    1131
    1132
    1133$ tuples
    1134
    1135/case(q2_softok)/       $ index assumed in range
    1136
    1137      tcomp(value(a1), ivalue(a2)) = heap(a3);
    1138      go to nxt;
    1139
    1140
    1141
    1142/case(q2_soft)/
    1143
smfd  33      indx = otvalue(a2);     $ index
    1145      p = value(a1);
    1146
    1147      if indx = 0 ! indx >= nelt(p) then  $ go off line
    1148          t1 = heap(a1);
    1149          call sof(t1, heap(a2), heap(a3));
    1150          heap(a1) = t1;
    1151      else
    1152          tcomp(p, indx) = heap(a3);
    1153      end if;
    1154
    1155      go to nxt;
    1156
    1157
    1158
    1159$ maps
    1160
    1161/case(q2_soflm)/                $ local maps + smaps
    1162
    1163      heap(ls_word(value(a1)) + value(a2)) = heap(a3);
    1164      go to nxt;
    1165
    1166
    1167
    1168/case(q2_sofrm)/                $ remote maps
    1169
    1170      indx = ebindx(value(a2)); $ get base index and pointer to tuple
    1171      p    = value(a1) + hl_rmap;
    1172
    1173      if indx <= maxindx(p) then   $ in range
    1174          tcomp(p, indx) = heap(a3);
    1175      else
    1176          t1 = heap(a1);
    1177          call sof(t1, heap(a2), heap(a3));  $ must reallocate
    1178          heap(a1) = t1;
    1179      end if;
    1180
    1181      go to nxt;
    1182
    1183
    1184
    1185/case(q2_sofa)/                 $ general case
    1186
    1187      t1 = heap(a1);
    1188      call sofa(t1, heap(a2), heap(a3), no);
    1189      heap(a1) = t1;
    1190
    1191      go to nxt;
    1192
    1193
    1194
    1195/case(q2_sofas)/    $ declared sets
    1196
    1197      t1 = heap(a1);
    1198      call sofa(t1, heap(a2), heap(a3), yes);
    1199      heap(a1) = t1;
    1200      go to nxt;
    1201
    1202
    1203
    1204/case(q2_sofalmm)/                $ local mmap
    1205
    1206      heap(ls_word(value(a1)) + value(a2)) = heap(a3);
    1207      is_multi(ls_word(value(a1)) + value(a2)) = yes;
    1208      go to nxt;
    1209
    1210
    1211
    1212/case(q2_sofarmm)/                $ remote mmap
    1213
    1214      $ get index and pointer to tuple
    1215      indx = ebindx(value(a2));
    1216      p    = value(a1) + hl_rmap;
    1217
    1218      if indx <= maxindx(p) then
    1219          tcomp(p, indx) = heap(a3);
    1220          is_multi_ tcomp(p, indx) = yes;
    1221      else
    1222          t1 = heap(a1);
    1223          call sofa(t1, heap(a2), heap(a3), yes);
    1224          heap(a1) = t1;
    1225      end if;
    1226
    1227      go to nxt;
    1228
    1229
    1230
    1231/case(q2_send)/
    1232
    1233      heap(a1) = send(heap(a1), heap(a2), heap(a3));
    1234      go to nxt;
    1235
    1236
    1237
    1238/case(q2_ssubst)/               $ the index of y is a1 of the next
    1239                             $ quadruple.
    1240
    1241      a4 = codea1(codep + inst_nw);
    1242
    1243      heap(a1) = ssubst(heap(a1), heap(a2), heap(a3), heap(a4));
    1244
    1245      codep = codep + 2*inst_nw;
    1246      return;
    1247
    1248
    1249
    1250/nxt/              $ advance to code pointer and return
    1251
    1252      codep = codep+inst_nw;
    1253
    1254
    1255      end subr intrp2;
       1 .=member intrp3
       2      subr intrp3;
       3
       4$ this is the third of four routines which make up the interpreter.
       5$ at this point, the current quadruple has been unpacked, and we
       6$ are ready to jump on its opcode.
       7
       8
       9      access nsintp;
      10
      11      size copy1(hs);
      12      size convert(hs);
      13      size equal(1),  $ functions called
      14           nullp(1),
      16           incs(1),
      17           member(1),
      18           memset(1),
      19           var_id(sds_sz),
      20           lt(1);
      21
      22
      23$ begin exection
      24
      25 .+st  init_time(st_lib);      $ start measuring library time
      26
      27      go to case(op) in q2_eqform1 to q2_nextd;
      28
      29
      30$ section 8: conversions
      31$ ---------- -----------
      32
      33
      34$ this section contains opcodes for conversions and related primitives.
      35$
      36$ we begin with a series of type tests. these are used to determine
      37$ whether an undeclared variable already has a desired type or
      38$ whether it must be converted. there are three tests:
      39$
      40$ 1. q2_eqform1
      41$
      42$    test whether a2 has form a3. if so assign it to a1 and skip
      43$    the next instruction. here a3 is always '_ b'.
      44$
      45$ 2. q2_eqform2
      46$
      47$    test whether a2 has form a3. if so, copy it and assign the copy
      48$    to a1. a3 is a set or tuple.
      49$
      50$ 3. q2_eqform3
      51$
      52$    this is like (2) but we set a2-s share bit and assign it to a1.
      53$
      54$ 4. q2_eqform4
      55$
      56$    test whether a2 is an element of the plex base a3.  since we
      57$    cannot compute the pointer if it is not, this yields an error.
      58
      59/case(q2_eqform1)/
      60
      61      if type(a2) = t_elmt then
      62          if ebform(value(a2)) = a3 then
      63              heap(a1) = heap(a2);
      64              codep = codep + inst_nw;
      65          end if;
      66      end if;
      67
      68      go to nxt;
      69
      70
      71/case(q2_eqform2)/
      72
      73      if ^ isprim(type(a2)) then
      74          if hform(value(a2)) = a3 then
      75              heap(a1) = copy1(heap(a2));
      76              codep = codep + inst_nw;
      77          end if;
      78      end if;
      79
      80      go to nxt;
      81
      82
      83/case(q2_eqform3)/
      84
      85      if ^ isprim(type(a2)) then
      86          if hform(value(a2)) = a3 then
      87              is_shared(a2) = yes;
      88              heap(a1) = heap(a2);
      89              codep = codep + inst_nw;
      90          end if;
      91      end if;
      92
      93      go to nxt;
      94
      95
      96/case(q2_eqform4)/            $ check if a2 is element of plex base a3
      97
      98      temp = heap(a2);   deref(temp);
      99
     100      if type_ temp = t_latom then
     101          if la_form(value_ temp) = a3 then
     102              heap(a1) = temp;
     103          else
     104              $ element of wrong plex base
     105              call err_type(79);
     106              heap(a1) = err_val(a3);
     107          end if;
     108      elseif is_om_ temp then
     109          $ recall that the code generator emits this check only if the
     110          $ input had the form f_gen
     111          heap(a1) = heap(ft_samp(a3));
     112      else
     113          $ not an element of a plex base
     114          call err_type(80);
     115          heap(a1) = err_val(a3);
     116      end if;
     117
     118      go to nxt;
     119
     120
     121/case(q2_convert)/
     122$ this opcode performs full conversions. its arguments are:
     123
     124$ a1:  pointer to result
     125$ a2:  pointer to input
     126$ a3:  form of result
     127
     128      heap(a1) = convert(heap(a2), a3);
     129
     130      go to nxt;
     131
     132
     133
     134/case(q2_locate)/      $ locate
     135
     136$ this opcode locates a2 in a base a3 and returns a pointer to it.
     137      if is_om(a2) then
     138          temp = template(value(a3));
     139          build_spec(heap(a1), t_oelmt, temp)
     140      else
     141          call locate(temp, heap(a2), value(a3), yes);
     142          build_spec(heap(a1), t_elmt,  temp)
     143      end if;
     144
     145      go to nxt;
     146
     147
     148
     149/case(q2_deref)/       $ multi level dereference
     150
     151$ assign a1 = a2, then dereference it a3 times.
     152
     153      temp = heap(a2);
     154
     155      do j = 1 to a3;
     156          deref1(temp);
     157      end do;
     158
     159      heap(a1) = temp;
     160
     161      go to nxt;
     162
     163
     164
     165/case(q2_deref1)/        $ one level dereference
     166
     167      temp = heap(a2);   deref1(temp);   heap(a1) = temp;
     168
     169      go to nxt;
     170
     171
     172
     173$ so called 'primitive conversions' are really just type and/or range
     174$ checks followed by an assignment. the various opcodes q2_checkxxx
     175$ test the type or value of a1 against a2 and abort if the test
     176$ fails. a2 is always an immediate argument, such as a type code
     177$ or range limit.
     178
     179
     180/case(q2_checktp)/
     181
     182$ a3 is a form. check that a2 has a type consistent with this form,
     183$ then assign it to a1.
     184
     185      temp = heap(a2);
     186
     187      deref(temp);
     188
     189      if otype_ temp = type(ft_samp(a3)) then
     190          heap(a1) = temp;
     191
stra  98      elseif otype_ temp = t_string & a3 = f_string then   $$$ patch $$$
stra  99          heap(a1) = temp;                                 $$$ patch $$$
stra 100                                                           $$$ patch $$$
stra 101      elseif otype_ temp = t_istring & a3 = f_sstring then $$$ patch $$$
stra 102          heap(a1) = temp;                                 $$$ patch $$$
stra 103                                                           $$$ patch $$$
     192      else
     193          if (^ is_om_ temp) call err_misc(17);
     194          heap(a1) = heap(ft_samp(a3));
     195      end if;
     196
     197      go to nxt;
     198
     199
     200
     201/case(q2_checki1)/  $ check that a1 is a short int <= a2
     202
     203      $ check that ivalue(a2) <= tvalue(a1) <= tvalue(a3).  this test is
smfb  82      $ only performed on typed long or short integers.
     205      t1 = tvalue(a1); t2 = ivalue(a2); t3 = ivalue(a3);
     206      if ( ^ (t2 <= t1 & t1 <= t3)) call err_misc(18);
     207
     208      go to nxt;
     209
     210
     211/case(q2_checki2)/  $ check that a1 is a long or short int
     212
     213      if (type(a1) = t_int)  go to nxt;
     214      if (type(a1) = t_lint) go to nxt;
     215
     216      call err_misc(19);
     217
     218      go to nxt;
     219
     220
     221/case(q2_chkatom)/            $ check that a2 is a short or long atom
     222
     223      if type(a2) = t_atom ! type(a2) = t_latom then
     224          heap(a1) = heap(a2);
     225      else
     226          call err_type(81);
     227          heap(a1) = err_val(f_atom);
     228      end if;
     229
     230      go to nxt;
     231
     232
     233
     234$ the opcodes q2_txxx are used to convert untyped values to typed
     235$ values. the corresponding opcodes q2_uxxx are used to convert
     236$ the other way.
     237
     238
     239/case(q2_tint1)/    $ short int = untyped int
     240
     241      if heap(a2) = om_int then  $ return om
     242          heap(a1) = zero;
     243          is_om(a1) = yes;
     244
     245      elseif heap(a2) < 0 ! heap(a2) > maxsi then
     246
     247          call err_misc(20);
     248
     249      else
     250          build_spec(heap(a1), t_int, heap(a2));
     251      end if;
     252
     253      go to nxt;
     254
     255
     256/case(q2_tint2)/     $ long int = untyped int
     257
     258$ we give three possible results, depending on the value of a2:
     259
     260$ 1. if a2 is om, we yield an om integer 0.
     261$ 2. if a2 is small enough, we yield a short integer.
     262$ 3. otherwise we yield a 1 word long integer.
     263
     264      put_intval(heap(a2),heap(a1));
     265
     266      go to nxt;
     267
     268
     269
     270/case(q2_treal)/              $ real := untyped real
     271
     272      put_realval(heap(a2), heap(a1));
     273
     274      go to nxt;
     275
     276
     277
     278/case(q2_uint1)/    $ untyped int = short int
     279
     280      if is_om(a2) then
     281          heap(a1) = om_int;
     282
     283      else
     284          heap(a1) = ivalue(a2);
     285      end if;
     286
     287      go to nxt;
     288
     289
     290
     291/case(q2_uint2)/    $ untyped int = long int
     292
     293      get_intval(heap(a1), heap(a2));
     294
     295      go to nxt;
     296
     297
     298
     299/case(q2_ureal1)/      $ untyped real = real
     300
     301      if is_om(a2) then
     302          heap(a1) = om_real;
     303
     304      else
     305          heap(a1) = rval(value(a2));
     306      end if;
     307
     308      go to nxt;
     309
     310
     311
     312/case(q2_ureal2)/             $ untyped real := general
     313
     314      if type(a2) = t_real then
     315          go to case(q2_ureal1);
     316
     317      else
     318          call err_misc(23);
     319
     320      end if;
     321
     322      go to nxt;
     323
     324
     325$ section 9: control primitives
     326$ ---------- ------------------
     327
     328/case(q2_goto)/   $ goto
     329
     330      codep = a1;
     331      return;
     332
     333
     334
     335$
     336$ case statements:  a1 is the case 'map', a2 the value of the 
     337$
     338/case(q2_caset)/              $ a1 is the case tuple, a2 is an integer
     339
     340      p    = value(a1);       $ pointer to tuple
smfb  83      indx = otvalue(a2);     $ index
     342
smfb  84      if 0 < indx & indx <= nelt(p) then
smfb  85          codep = value_ tcomp(p, indx);  $ retrieve label
smfb  86          return;
     350      end if;
     351
     352      go to nxt;
     353
     354
     355
     356/case(q2_caselsm)/            $ a1 is a local smap, a2 a pointer
     357
     358      temp = heap(value(a2)+ls_word(value(a1)));
     359
     360      if ^ is_om_ temp then
     361          codep = value_ temp;
     362          return;
     363      end if;
     364
     365      go to nxt;
     366
     367
     368
     369/case(q2_casersm)/            $ a1 is a remote smap, a2 a pointer
     370
     371      p    = value(a1) + hl_rmap; $ pointer to embedded tuple
     372      indx = ebindx(value(a2));   $ base index
     373
     374      if indx <= maxindx(p) then
     375          temp = tcomp(p, indx);  $ retrieve label
     376
     377          if ^ is_om_ temp then
     378              codep = value_ temp;
     379              return;
     380          end if;
     381      end if;
     382
     383      go to nxt;
     384
     385
     386
     387/case(q2_caseusm)/            $ a1 is an unbased smap, a2 any setl value
     388
     389      call locate(pos, heap(a2), value(a1), no); $ locate a2 in a1
     390
     391      if loc_found then
     392          codep = value_ ebimag(pos);
     393          return;
     394      end if;
     395
     396      go to nxt;
     397
     398
     399
     400                              $ branch on equality
     401
     402/case(q2_goeq1)/                $ one word test
     403
     404      if heap(a2) = heap(a3) then
     405          codep = a1;
     406          return;
     407      end if;
     408
     409      go to nxt;
     410
     411
     412
     413/case(q2_goeqv)/                $ test value and type
     414
     415      if eq(heap(a2), heap(a3)) then
     416          codep = a1;
     417          return;
     418      end if;
     419
     420      go to nxt;
     421
     422
     423
     424/case(q2_goeq)/                 $ general test
     425
     426      if eq(heap(a2), heap(a3)) then
     427          codep = a1;
     428          return;
     429
     430      elseif ne(heap(a2), heap(a3)) then
     431          go to nxt;
     432
     433      elseif equal(heap(a2), heap(a3)) then
     434          codep = a1;
     435          return;
     436
     437      else
     438          go to nxt;
     439      end if;
     440
     441
     442
     443/case(q2_gozr)/                 $ branch if a2 = 0
     444
     445      if tvalue(a2) = 0 then
     446          codep = a1;
     447          return;
     448      end if;
     449
     450      go to nxt;
     451
     452
     453
     454/case(q2_gotrue)/             $ if a2 = true then go to a1; end;
     455
     456      if (eq(heap(a2), heap(s_false))) go to nxt;
     457
     458      if eq(heap(a2), heap(s_true)) then
     459          codep = a1;
     460          return;
     461      end if;
     462
     463      call err_type(64);
     464      heap(a1) = err_val(f_gen);
     465
     466      go to nxt;
     467
     468
     469/case(q2_gofalse)/            $ if a2 = false then go to a1; end;
     470
     471      if (eq(heap(a2), heap(s_true))) go to nxt;
     472
     473      if eq(heap(a2), heap(s_false)) then
     474          codep = a1;
     475          return;
     476      end if;
     477
     478      call err_type(64);
     479      heap(a1) = err_val(f_gen);
     480
     481      go to nxt;
     482
     483
     484/case(q2_goom)/  $ if a2 = om goto a2
     485
     486      if is_om(a2) then
     487          codep = a1;
     488          return;
     489      end if;
     490
     491      go to nxt;
     492
     493
     494
     495/case(q2_gonl)/                 $ branch if heap(a2) = nl.
     496      if nullp(value(a2)) then
     497          codep = a1;
     498          return;
     499      end if;
     500
     501      go to nxt;
     502
     503
     504/case(q2_gonult)/   $ go if tuple = nult
     505
     506      if nelt(value(a2)) = 0 then
     507          codep = a1;
     508          return;
     509      end if;
     510
     511      go to nxt;
     512
     513
     514
     515/case(q2_gogei)/                $ branch on ge. - short ints.
     516
     517      if ivalue(a2) >= ivalue(a3) then
     518          codep = a1;
     519          return;
     520      end if;
     521
     522      go to nxt;
     523
     524
     525/case(q2_gogeui)/  $ untyped ints
     526
     527      if heap(a2) >= heap(a3) then
     528          codep = a1;
     529          return;
     530      end if;
     531
     532      go to nxt;
     533
     534
     535
     536/case(q2_gogeur)/   $ untyped reals
     537
     538      real1 = heap(a2);
     539      real2 = heap(a3);
     540
     541      if real1 >= real2 then
     542          codep = a1;
     543          return;
     544      end if;
     545
     546      go to nxt;
     547
     548
     549
     550/case(q2_goge)/                 $ branch on ge - general case
     551
     552      if (otype(a2) = t_int & otype(a3) = t_int) go to case(q2_gogei);
     553
mjsa  28      if ^ lt(heap(a2), heap(a3)) then
     555          codep = a1;
     556          return;
     557      end if;
     558
     559      go to nxt;
     560
     561
     562
     563/case(q2_goincs)/
     564
     565      if incs(heap(a2), heap(a3)) then
     566          codep = a1;
     567          return;
     568      end if;
     569
     570      go to nxt;
     571
     572
     573
     574                             $ branch on in
     575
     576
     577
     578
     579/case(q2_goin)/                 $ general case
     580
     581      if member(heap(a2), heap(a3)) then
     582          codep = a1;
     583          return;
     584      end if;
     585
     586      go to nxt;
     587
     588
     589
     590/case(q2_goins)/      $ general set/map case
     591
     592      if memset(heap(a2), heap(a3)) then
     593          codep = a1;
     594          return;
     595      end if;
     596
     597      go to nxt;
     598
     599
     600
     601/case(q2_goinus)/     $ unbased set
     602
     603      call locate(pos, heap(a2), value(a3), no);
     604      if loc_found then
     605          codep = a1;
     606          return;
     607      end if;
     608
     609      go to nxt;
     610
     611
     612
     613/case(q2_goinl)/       $ local set
     614
     615      p = value(a3);
     616
     617      if .f. ls_bit(p), 1, heap(value(a2)+ls_word(p)) then
     618          codep = a1;
     619          return;
     620      end if;
     621
     622      go to nxt;
     623
     624
     625
     626/case(q2_goinr)/    $ remote set
     627
     628      indx = ebindx(value(a2));   $ get eb index and ptr to bit string
     629      p = value(a3);
     630
     631      if indx > rs_maxi(p) then
     632          go to nxt;
     633
     634      elseif rsbit(p, indx) then
     635          codep = a1;
     636          return;
     637
     638      else
     639          go to nxt;
     640      end if;
     641
     642
     643
     644/case(q2_golti)/                $ branch on lt -  int
     645
     646      if ivalue(a2) < ivalue(a3) then
     647          codep = a1;
     648          return;
     649      end if;
     650
     651      go to nxt;
     652
     653
     654/case(q2_goltui)/   $ untyped ints
     655
     656      if heap(a2) < heap(a3) then
     657          codep = a1;
     658          return;
     659      end if;
     660
     661      go to nxt;
     662
     663
     664
     665/case(q2_goltur)/  $ untyped reals
     666
     667      real1 = heap(a2);
     668      real2 = heap(a3);
     669
     670      if real1 < real2 then
     671          codep = a1;
     672          return;
     673      end if;
     674
     675      go to nxt;
     676
     677
     678
     679/case(q2_golt)/                 $ branch on lt - general case
     680
     681      if (otype(a2) = t_int & otype(a3) = t_int) go to case(q2_golti);
     682
     683      if lt(heap(a2), heap(a3)) then
     684          codep = a1;
     685          return;
     686      end if;
     687
     688      go to nxt;
     689
     690
     691
     692/case(q2_gone1)/                $ one word compare
     693
     694      if heap(a2) ^= heap(a3) then
     695          codep = a1;
     696          return;
     697      end if;
     698
     699      go to nxt;
     700
     701
     702
     703/case(q2_gonev)/                $ compare value and type.
     704
     705      if ^ eq(heap(a2), heap(a3)) then
     706          codep = a1;
     707          return;
     708      end if;
     709
     710      go to nxt;
     711
     712
     713
     714/case(q2_gone)/                 $ general test
     715
     716      if (eq(heap(a2), heap(a3))) go to nxt;
     717
     718      if ne(heap(a2), heap(a3)) then
     719          codep = a1;
     720          return;
     721      end if;
     722
     723      if (equal(heap(a2), heap(a3))) go to nxt;
     724
     725      codep = a1;
     726      return;
     727
     728
     729
     730/case(q2_gonz)/                 $ branch on non zero
     731
     732      if ivalue(a2) ^= 0 then
     733          codep = a1;
     734          return;
     735      end if;
     736
     737      go to nxt;
     738
     739
     740
     741/case(q2_gonom)/  $ if a2 /= om then goto a2;;
     742
     743      if ^ is_om(a2) then
     744          codep = a1;
     745          return;
     746      end if;
     747
     748      go to nxt;
     749
     750
     751
     752/case(q2_gonnl)/                $ branch on not nl
     753
     754      if ^ nullp(value(a2)) then
     755          codep = a1;
     756          return;
     757      end if;
     758
     759      go to nxt;
     760
     761
     762/case(q2_gonnult)/  $ branch if tuple ^= nult
     763
     764      if nelt(value(a2)) ^= 0 then
     765          codep = a1;
     766          return;
     767      end if;
     768
     769      go to nxt;
     770
     771
     772
     773
     774/case(q2_gonincs)/            $ if not a2 incs a3 then go to a1; end;
     775
     776      if ^ incs(heap(a2), heap(a3)) then
     777          codep = a1;
     778          return;
     779      end if;
     780
     781      go to nxt;
     782
     783
     784/case(q2_gonin)/      $ general case
     785
     786
     787      if ^ member(heap(a2), heap(a3)) then
     788          codep = a1;
     789          return;
     790      end if;
     791
     792      go to nxt;
     793
     794
     795/case(q2_gonins)/     $ general set/map case
     796
     797      if ^ memset(heap(a2), heap(a3)) then
     798          codep = a1;
     799          return;
     800      end if;
     801
     802      go to nxt;
     803
     804
     805
     806/case(q2_goninus)/   $ unbased set
     807
     808      call locate(pos, heap(a2), value(a3), no);
     809
     810      if ^ loc_found then
     811          codep = a1;
     812          return;
     813      end if;
     814
     815      go to nxt;
     816
     817
     818
     819/case(q2_goninl)/                  $ local subset
     820
     821      p = value(a3);
     822
     823      if ^ .f. ls_bit(p), 1, heap(value(a2)+ls_word(p)) then
     824          codep = a1;
     825          return;
     826      end if;
     827
     828      go to nxt;
     829
     830
     831
     832/case(q2_goninr)/               $ remote subset
     833
     834      $ get index and pointer to bit string
     835      indx = ebindx(value(a2));
     836      p = value(a3);
     837
     838      if indx > rs_maxi(p) then
     839          codep = a1;
     840          return;
     841
     842      elseif ^ rsbit(p, indx) then
     843          codep = a1;
     844          return;
     845      end if;
     846
     847      go to nxt;
     848
     849
     850
     851
     852
     853$ set iterators - (forall x in s)
     854$ --- ---------   ---------------
     855
     856$ this section contains opcodes for four primitives:
     857
     858$ 1. inext:   initialize set iterator
     859$ 2. next:    advance set iterator
     860$ 3. inextd:  initialize domain iterator
     861$ 4. nextd:   advance domain iterator
     862
     863$ their arguments are:
     864
     865$ a1:     pointer to bound variable
     866$ a2:     pointer to temporary used to hold place in set
     867$ a3:     pointer to set
     868
     869
     870
     871/case(q2_inexts)/          $ initialize next for set.
     872
     873      temp = template(value(a3));  $ point to template
     874
     875      heap(a1) = ebspec(temp);
     876      build_spec(heap(a2), t_elmt, temp);
     877
     878      go to nxt;
     879
     880
     881
     882/case(q2_inextt)/    $ initialize next for tuple
     883
     884      heap(a2) = zero;
     885      go to nxt;
     886
     887
     888
     889/case(q2_inext)/    $ general initialization
     890
     891      t3 = heap(a3);
     892
     893      call inext(t1, t2, t3);
     894
     895      heap(a1) = t1;
     896      heap(a2) = t2;
     897      heap(a3) = t3;
     898
     899      go to nxt;
     900
     901
     902/case(q2_nextus)/   $ next on unbased sets
     903
     904      p = value(a2);  $ get pointer into set
     905
     906      while 1;
     907          p = eblink(p);
     908          if (^ is_ebhedr(p)) quit;   $ valid element
     909          if (is_ebtemp(p)) quit;
     910      end while;
     911
     912      value(a2)                   = p;  $ install new pointer
     913      if (is_ebtemp(p)) is_om(a2) = yes;
     914
     915      is_shared_ ebspec(p) = yes;
     916      heap(a1) = ebspec(p);
     917
     918      go to nxt;
     919
     920
     921
     922/case(q2_nextls)/    $ next for local sets
     923
     924      lsw = ls_word(value(a3));  $ get word and bit position in base
     925      lsb = ls_bit(value(a3));
     926
     927      p = value(a2);   $ get pointer into base
     928
     929      while 1;
     930          p = eblink(p);
     931          if is_ebhedr(p) then
     932              if (is_ebtemp(p)) quit;
     933              cont;
     934          end if;
     935
     936          if (.f. lsb, 1, heap(p+lsw)) quit;   $ found next element
     937      end while;
     938
     939      value(a2)                   = p;
     940      if (is_ebtemp(p)) is_om(a2) = yes;
     941
     942      heap(a1) = heap(a2);
     943
     944      go to nxt;
     945
     946
     947
     948/case(q2_nextrs)/      $ next on remote sets
     949
     950      p = value(a2);   $ get pointer into base
     951      p1 = value(a3);
     952
     953      while 1;
     954          p = eblink(p);   $ advance in base
     955          if is_ebhedr(p) then
     956              if (is_ebtemp(p)) quit;  $ end of set
     957              cont;
     958          end if;
     959
     960          $ check set membership
     961          indx = ebindx(p);
     962          if (indx > rs_maxi(p1)) cont; $ index out of range
     963          if (rsbit(p1, indx))    quit; $ found next element
     964      end while;
     965
     966      value(a2)                   = p;   $ store new pointer
     967      if (is_ebtemp(p)) is_om(a2) = yes;
     968
     969      heap(a1) = heap(a2);
     970
     971      go to nxt;
     972
     973
     974
     975/case(q2_nextt)/              $ next for tuples
     976
     977      indx = ivalue(a2) + 1;  $ current index in tuple
     978      p    = value(a3);
     979
     980      if indx <= nelt(p) then
     981          is_shared_ tcomp(p, indx) = yes;
     982          heap(a1) = tcomp(p, indx);
     983          ivalue(a2) = indx;
     984
     985      else
     986          heap(a1) = tcomp(p, 0);
     987          heap(a2) = spec_om;
     988      end if;
     989
     990      go to nxt;
     991
     992
     993/case(q2_nextut)/             $ untyped tuples
     994
     995      indx = ivalue(a2) + 1;
     996      p    = value(a3);
     997
     998      if indx <= nelt(p) then
     999          heap(a1) = tcomp(p, indx);
    1000          ivalue(a2) = indx;
    1001
    1002      else
    1003          heap(a1) = tcomp(p, 0);
    1004          heap(a2) = spec_om;
    1005      end if;
    1006
    1007      go to nxt;
    1008
    1009
    1010/case(q2_next)/               $ general case
    1011
    1012      t1 = heap(a1);
    1013      t2 = heap(a2);
    1014
    1015      call next(t1, t2, heap(a3));
    1016
    1017      heap(a1) = t1;
    1018      heap(a2) = t2;
    1019
    1020      go to nxt;
    1021
    1022
    1023/case(q2_nexts)/     $ next for sets
    1024
    1025$ this is identical to the general case except that we call 'nexts'
    1026$ directly.
    1027
    1028      t1 = heap(a1);
    1029      t2 = heap(a2);
    1030
    1031      call nexts(t1, t2, heap(a3));
    1032
    1033      heap(a1) = t1;
    1034      heap(a2) = t2;
    1035
    1036      go to nxt;
    1037
    1038
    1039
    1040/case(q2_inextd)/       $ initialize domain iterator
    1041
    1042      t3 = heap(a3);
    1043
    1044      call inextd(t1, t2, t3);
    1045
    1046      heap(a1) = t1;
    1047      heap(a2) = t2;
    1048      heap(a3) = t3;
    1049
    1050      go to nxt;
    1051
    1052
    1053/case(q2_nextd)/      $ domain iterator
    1054
    1055$ this nubbin is very similar to q2_next. the test for the end of
    1056$ the loop is a seperate instruction.
    1057      t1 = heap(a1);
    1058      t2 = heap(a2);
    1059
    1060      call nextd(t1, t2, heap(a3));
    1061
    1062      heap(a1) = t1;
    1063      heap(a2) = t2;
    1064
    1065      go to nxt;
    1066
    1067
    1068
    1069
    1070/nxt/
    1071
    1072      codep = codep + inst_nw;
    1073
    1074
    1075      end subr intrp3;
       1 .=member intrp4
       2      subr intrp4;
       3
       4$ this is the final part of the interpreter.
       5
       6      access nsintp;
       7
       8      size var_id(sds_sz),
       9           sopen(hs),
      10           sclose(hs),
      11           print(hs),
      12           printa(hs),
      13           readr(hs),
      14           reada(hs),
      15           getr(hs),
      16           putr(hs),
      17           getb(hs),
      18           putb(hs),
      19           getk(hs),
      20           putk(hs),
      21           getf(hs),
      22           callf(hs),
      23           putf(hs),
      24           rewindr(hs),
      25           eof(hs),
      26           eject(hs),
      27           title(hs),
      28           shost(hs),
      29           sgtipp(hs),
      30           sgtspp(hs),
      31           getem(hs),
      32           setem(hs),
      33           span(hs),
      34           break(hs),
      35           match(hs),
      36           lpad(hs),
      37           len(hs),
      38           sany(hs),
      39           notany(hs),
      40           rspan(hs),
      41           rbreak(hs),
      42           rmatch(hs),
      43           rpad(hs),
      44           rlen(hs),
      45           rany(hs),
      46           rnotany(hs);
      47
      48 .+st  init_time(st_lib);      $ start measuring library time
      49
      50      go to case(op) in q2_call to q2_maximum;
      51
      52
      53
      54
      55
      56$ subroutine linkage
      57
      58
      59$ each time we call a setl procedure, we stack:
      60$ 1. the return address
      61$ 2. the number of arguments of the current procedure (i.e. -na-)
      62
      63$ the following macro gives the number of words saved by each
      64$ procedure call:
      65
      66      +*  linkage_nwords  = 2  **  $ codep and na
      67
      68
      69/case(q2_call)/   $ call
      70
      71      build_spec(t1, t_lab, codep + inst_nw);
      72      build_spec(t2, t_int, cur_na);
      73
      74      push2(t1, t2);
      75      savet = t;
      76
      77      codep  = a1;
      78      cur_na = ivalue(a3);
      79
      80      return;
      81
      82
      83/case(q2_ucall)/   $ call unsatisfied external
      84
      85      call err_misc(31);
      86
      87      cur_arg = 0;   $ so 'bpop1' actually pops stack
      88
      89      go to nxt;
      90
      91
      92/case(q2_retn)/   $ return
      93
      94      pop2(t2, t1);
      95
      96      codep  = value_ t1;
      97      cur_na = value_ t2;
      98
      99      savet = t;
     100
     101      return;
     102
     103$ the following opcodes are used only during assembly code generation, a
     104$ are treated as noops:
     105
     106/case(q2_lab)/
     107
     108/case(q2_tag)/
     109
     110/case(q2_mentry)/
     111
     112/case(q2_pentry)/
     113
     114      go to nxt;
     115
     116
     117
     118
     119$ in the opcodes for routine prologues and epilogues, a1 points
     120$ to the beginning of a block in the symbol table and a2 is the
     121$ length of the block.
     122
     123
     124/case(q2_swap)/               $ swap parameters for recursive call
     125
     126      temp = t + linkage_nwords;
     127      do j = 0 to a2-1;
     128          swap( heap(a1+j), heap(temp+j) );
     129      end do;
     130
     131      go to nxt;
     132
     133
     134
     135/case(q2_savel)/              $ save local variables on the stack
     136
     137      get_stack(a2); savet = t;
     138
     139      do j = 0 to a2-1;
     140          heap(t+j) = heap(a1+j);   heap(a1+j) = spec_om;
     141      end do;
     142
     143      go to nxt;
     144
     145
     146
     147/case(q2_loadp)/              $ move parameters for non-recursive call
     148
     149      temp = t + linkage_nwords;
     150      do j = 0 to a2-1;
     151          heap(a1+j) = heap(temp+j);
     152      end do;
     153
     154      go to nxt;
     155
     156
     157
     158/case(q2_resetp)/             $ restore params after non-recursive call
     159
     160      temp = t + linkage_nwords;
     161      do j = 0 to a2-1;
     162          heap(temp+j) = heap(a1+j);
     163      end do;
     164
     165      go to nxt;
     166
     167
     168
     169/case(q2_clearl)/             $ set the local variables to omega
     170
     171      do j = 0 to a2-1;
     172          heap(a1+j) = spec_om;
     173      end do;
     174
     175      go to nxt;
     176
     177
     178
     179/case(q2_resetl)/             $ restore local variables from the stack
     180
     181      do j = 0 to a2-1;
     182          heap(a1+j) = heap(t+j);
     183      end do;
     184
     185      free_stack(a2); savet = t;
     186
     187      go to nxt;
     188
     189
     190
     191$ backtracking opcodes
     192$ --------------------
     193
     194$ this section contains opcodes used for backtracking.  some of them
     195$ duplicate the code for primitives such as q2_swap, etc. which are
     196$ generated as part of recursive routine prologues and epilogues.  the
     197$ compiler will generate one or the other set of instructions depending
     198$ on whether backtracking is used.
     199$
     200$ backtracking operates by placing a series of 'environment blocks' on
     201$ the stack.  environment blocks have the following format:
     202$
     203$ word 1:       code pointer to instruction to restore environment
     204$ word 2:       integer giving pointer to next environment block
     205$ word 3:       integer giving number of saved values
     206$
     207$ the remaining words contain specifiers for saved values.
     208$
     209$ there are three types of environment blocks:
     210$
     211$ 1. entry blocks
     212$
     213$    entry blocks are created be q2_entry instructions upon entry to a
     214$    procedure, or are restored after a conditional return is followed
     215$    by a fail, which will result in the execution of an q2_undo
     216$    instructions.  they are removed by q2_exit instructions, if the
     217$    return is unconditional (i.e. no backtracking points remain in this
     218$    invocation), or by the q2_dexit instruction after a fail returns
     219$    control to a backtracking point before the current invocation.
     220$
     221$ 2. exit blocks
     222$
     223$    exit blocks are created whenever a return statement is executed
     224$    (i.e. an q2_exit instruction) while there still remain ok blocks on
     225$    the stack.  this situation requires a conditional return, which can
     226$    be reversed if a subsequent fail returns to an ok block of this
     227$    procedure.  exit blocks are changed back into entry blocks by
     228$    q2_undo instructions.
     229$
     230$ 3. ok blocks
     231$
     232$    ok blocks are created by the q2_ok instruction and removed by the
     233$    q2_succeed and q2_fail2 instructions.  they represent the actual
     234$    backtracking points to which fail statements return.
     235
     236
     237$ the following global variables are used for backtracking:
     238$
     239$ 1. back_flag:
     240$
     241$    this variable is read in with the q2 code. it indicates whether the
     242$    compiler generated code for backtracking or whether it used the
     243$    standard opcodes for procedure linkage, etc.
     244$
     245$ 2. last_env:
     246$
     247$    this variable contains the head of a list of saved environments
     248$
     249$ 3. ok_lev:
     250$
     251$    this an integer giving the number of ok blocks currently being
     252$    saved.  when ok_lev = 0 we are not doing any backtracking, and
     253$    procedure linkage is very similar to the code generated when
     254$    backtracking is disabled.
     255
     256
     257      +* push_env(codeptr, len)  =   $ push environment block
     258          build_spec(t1, t_int, len);
     259          build_spec(t2, t_int, last_env);
     260          build_spec(t3, t_lab, codeptr);
     261
     262          push3(t1, t2, t3);   savet = t;
     263
     264          last_env = t;
     265          **
     266
     267
     268/case(q2_bcall)/              $ backtracked procedure call
     269
     270$ this instruction is identical to q2_call.
     271
     272      build_spec(t1, t_lab, codep+inst_nw);
     273      build_spec(t2, t_int, cur_na);
     274
     275      push2(t1, t2);   savet = t;
     276
     277      codep  = a1;
     278      cur_na = value(a3);
     279
     280      return;
     281
     282
     283/case(q2_entry)/              $ procedure entry
     284
     285$ the q2_entry instruction is a  combination  of  all  the  instructions
     286$ normally generated as part of a recursive routine prologue.
     287$
     288$ the values placed on the stack by a q2_entry instruction are known  as
     289$ an 'entry block'.  they consist  of  the  old  values  of  the  formal
     290$ parameters, the old values of local variables, and a code  pointer  to
     291$ the q2_dexit instruction for the routine.
     292$
     293$ the arguments of an q2_entry instruction are:
     294$
     295$  a1:  pointer to q2_dexit instruction
     296$  a2:  address of 0-th formal parameter
     297$  a3:  length of formal parameter block
     298$  a4:  address of 0-th local variable
     299$  a5:  length of local variables block
     300
     301      $ get remaining arguments
     302      a4 = codea1(codep + inst_nw);
     303      a5 = codea2(codep + inst_nw);
     304
     305      reserve(a5 + 4);        $ no garbage collection hereafter
     306
     307      $ swap parameters.  this is identical to q2_swap.
     308      temp = t + linkage_nwords;
     309      do j = 0 to a3-1;
     310          swap( heap(a2+j), heap(temp+j) );
     311      end do;
     312
     313      $ save local variables.  this is identical to q2_savel.
     314      get_stack(a5);
     315      do j = 0 to a5-1;
     316          heap(t+j) = heap(a4+j);   heap(a4+j) = spec_om;
     317      end do;
     318
     319      $ push the extra word needed by the q2_undo instruction.
     320      push1(zero);
     321
     322      $ push the new environment block.
     323      push_env(a1, a3+a5+3);
     324                 $ ^^^^^^^----------------------------- a5+2+a3+1
     325
     326      codep = codep + 2 * inst_nw;  $ two-word instruction
     327      return;
     328
     329
     330/case(q2_exit)/               $ procedure exit
     331
     332$ q2_exit contains the entire routine epilog used for backtracking.   it
     333$ restores the stack and symbol table, then performs the actual return.
     334$
     335$ there are two possibilities:
     336$
     337$ 1. the top environment block is an 'entry' block.  this means that  we
     338$    have not done an 'ok' since the procedure was called.   treat  this
     339$    like a normal return.
     340$
     341$ 2. otherwise the return is conditional, as in 'if ok then return'.  we
     342$    convert the entry block into an exit block, which in  turn  can  be
     343$    reversed by a q2_undo instruction.
     344$
     345$ the arguments of an q2_exit instruction are identical to the arguments
     346$ of an q2_entry instruction, except that a1 points to the q2_undo
     347$ instruction.
     348
     349      $ get remaining arguments
     350      a4 = codea1(codep + inst_nw);
     351      a5 = codea2(codep + inst_nw);
     352
     353      $ find last entry block
     354      cur_env  = last_env;   prev_env = 0;
     355      while codeop(value(cur_env)) ^= q2_dexit;  $ entry block
     356          prev_env = cur_env;   cur_env = value(cur_env + 1);
     357      end while;
     358
     359      if cur_env = t then    $ return unconditionally: pop entry block
     360
     361          $ get next environment
     362          last_env = value(cur_env+1);
     363
     364          $ free this environment block header, and throw away the extra
     365          $ word needed by the q2_undo instruction.
     366          free_stack(4);
     367
     368          $ reset the local variables.
     369          do j = 0 to a5-1;
     370              heap(a4+j) = heap(t+j);
     371          end do;
     372          free_stack(a5);
     373
     374          $ swap the parameters
     375          temp = t + linkage_nwords;
     376          do j = 0 to a3-1;
     377              swap( heap(a2+j), heap(temp+j) );
     378          end do;
     379
     380          $ set cur_arg = 0, indicating that stack pops are to be made
     381          $ directly from the top of the stack.
     382          cur_arg = 0;
     383
     384          $ pop codep and na then return
     385          pop2(t2, t1);   savet = t;
     386
     387          codep  = value_ t1;
     388          cur_na = value_ t2;
     389
     390      else    $ return conditionally: change the entry to an exit block
     391
     392          $ swap local variables
     393          temp = cur_env + 3 + 1;
     394          do j = 0 to a5-1;
     395              swap( heap(a4+j), heap(temp+j) );
     396          end do;
     397
     398          $ get return address and na, the number of arguments.
     399          codep  = value(cur_env + a5 + 5);
     400          cur_na = value(cur_env + a5 + 4);
     401
     402          $ swap parameters.
     403          temp = cur_env + 4 + a5 + 2;
     404          do j = 0 to a3-1;
     405              swap( heap(a2+j), heap(temp+j) );
     406          end do;
     407
     408          $ set cur_arg to point to the stack entry for the last
     409          $ parameter.
     410          cur_arg = cur_env+a5+6;
     411                          $ ^^^^----------------------- 3+1+a5+2
     412
     413          $ set top word of environment block to point to q2_undo rather
     414          $ than q2_dexit instruction.
     415          value(cur_env) = a1;
     416
     417          $ move the exit block to the end of list of environments of
     418          $ the current routine.
     419          if cur_env ^= last_env then
     420              value(prev_env+1) = value(cur_env+1);
     421              value(cur_env+1)  = last_env;
     422              value(cur_env+3)  = prev_env;
     423              last_env          = cur_env;
     424          end if;
     425      end if;
     426
     427      return;
     428
     429
     430/case(q2_bpop1)/       $ stack pop
     431
     432$ this opcode pops a procedure argument from the stack in the
     433$ backtracking mode.
     434$
     435$ there are two possibilities:
     436$
     437$ cur_arg = 0:      treat like a normal pop
     438$ cur_arg ^= 0:     set a1 = heap(cur_arg) and increment cur_arg.
     439
     440      if cur_arg = 0 then
     441          pop1(heap(a1));   savet = t;
     442      else
     443          heap(a1) = heap(cur_arg);
     444          cur_arg  = cur_arg+1;
     445      end if;
     446
     447      go to nxt;
     448
     449
     450/case(q2_bpopu1)/             $ stack pop for untyped values
     451
     452      if cur_arg = 0 then
     453          free_stack(1);          $ skip word
     454          pop1(heap(a1));
     455          savet = t;
     456      else
     457          cur_arg  = cur_arg+1;   $ skip word
     458          heap(a1) = heap(cur_arg);
     459          cur_arg  = cur_arg + 1;
     460      end if;
     461
     462      go to nxt;
     463
     464
     465/case(q2_bfree)/              $ free
     466
     467      if cur_arg = 0 then
     468          free_stack(value(a1));   savet = t;
     469      else
     470          cur_arg = cur_arg + value(a1);
     471      end if;
     472
     473      go to nxt;
     474
     475
     476/case(q2_ok)/                 $ ok
     477
     478$ this instruction is generated for an 'ok'.  its arguments are:
     479$
     480$ a1:    code pointer to q2_fail2 instruction
     481$ a2:    number of saved variables
     482$
     483$ it is followed by a series of q2_noop instructions whose  arg1  fields
     484$ contain pointers to the variables to be saved.
     485
     486      reserve(a2+4);          $ no garbage collection hereafter
     487
     488      $ push saved values
     489      get_stack(a2);
     490
     491      p = codep;
     492
     493      do j = 0 to a2-1;
     494          p = p + inst_nw;   p1 = codea1(p);
     495
     496          is_shared(p1) = yes;
     497          heap(t+j) = heap(p1);
     498      end do;
     499
     500      $ push a code pointer to the return address
     501      build_spec(t1, t_lab, p+inst_nw);
     502      push1(t1);
     503
     504      push_env(a1, a2+1);
     505
     506      ok_lev        = ok_lev + 1;
     507      heap(s_okval) = heap(s_true);
     508
     509      codep = p + inst_nw;
     510      return;
     511
     512
     513/case(q2_lev)/                $ get ok level
     514
     515      build_spec(heap(a1), t_int, ok_lev);
     516      go to nxt;
     517
     518
     519/case(q2_fail1)/              $ fail
     520
     521$ this instruction corresponds to the 'fail' statement.  at  this  point
     522$ the stack contains a series of blocks built by q1_exit, q1_entry,  and
     523$ q2_ok instructions.  the top  word  of  each  block  contains  a  code
     524$ pointer to either:
     525$
     526$ q1_dexit:     dummy return
     527$ q2_undo:      undoes a q2_exit instruction
     528$ q2_fail2:     undoes an ok
     529$
     530$ the q2_dexit and q2_undo instructions will continue to pop environment
     531$ blocks from the stack; the q2_fail2 instruction  will  branch  to  the
     532$ instruction after the last 'ok'.
     533$
     534$ when we reach a 'fail' statement the stack contains:
     535$
     536$ 1. an assortment ok, entry, and exit blocks.
     537$ 2. the topmost ok block.
     538$ 3. the entry blocks for all procedures called since the last ok.
     539$
     540$ the stack may also contain specifiers which were pushed onto the stack
     541$ as part of setformers, etc.  these specifiers are  sandwiched  between
     542$ environment blocks.
     543$
     544$ when we do a q2_undo instruction we are converting an exit block  back
     545$ to an entry block.  this means that the block we  are  working  on  is
     546$ burried somewhere in the middle of the stack.
     547$
     548$ when we do a q2_dexit or q2_fail2 instruction we are always working on
     549$ the top environment block.
     550$
     551$ when we remove an entry block as part of a q2_dexit instruction we not
     552$ only remove the block itself, but also all the  specifiers  sandwiched
     553$ between the entry block and the block beneath it.
     554
     555      if (ok_lev = 0) call err_fatal(47);
     556      ok_lev = ok_lev - 1;
     557
     558      codep = value(last_env);
     559      return;
     560
     561
     562/case(q2_dexit)/              $ dummy exit
     563
     564$ this instruction performs a normal subroutine exit except that instead
     565$ of branching to the return address, it branches back to q2_fail1.
     566$
     567$ the arguments of an q2_dexit instruction are:
     568$
     569$  a1:  address of 0-th formal parameter.
     570$  a2:  length of formal parameter block.
     571$  a3:  address of 0-th local variable.
     572$  a4:  length of local variable block.
     573
     574      $ pop the environment block, and throw away  the  extra  specifier
     575      $ used by q2_undo instructions.
     576      last_env = value(last_env+1);
     577      free_stack(4);
     578
     579      $ get remaining arguments
     580      a4 = codea1(codep + inst_nw);
     581
     582      $ reset local variables
     583      do j = 0 to a4-1;
     584          heap(a3+j) = heap(t+j);
     585      end do;
     586      free_stack(a4);
     587
     588      $ swap parameters
     589      temp = t + linkage_nwords;
     590      do j = 0 to a2-1;
     591          swap( heap(a1+j), heap(temp+j) );
     592      end do;
     593
     594      $ throw away codep, na, and the actual parameters.
     595      free_stack(a2+2);
     596
     597      $ throw away all specifiers sandwiched between this block and the
     598      $ next one.
     599      t = last_env;   savet = t;
     600
     601      codep = value(last_env);
     602      return;
     603
     604
     605/case(q2_undo)/               $ undo conditional return
     606
     607$ this instruction reverses the stack manipulation performed by  q2_exit
     608$ instructions as part of a conditional return.
     609$
     610$ note that when we execute this instruction the  environment  block  we
     611$ are working on is always burried somewhere deep in the stack.
     612$
     613$ the arguments for q2_undo are just like those for q2_exit except that
     614$ a1 points to the q2_dexit instruction.
     615
     616      $ get remaining arguments
     617      a4 = codea1(codep + inst_nw);
     618      a5 = codea2(codep + inst_nw);
     619
     620      $ swap local variables
     621      temp = last_env + 4;
     622      do j = 0 to a5-1;
     623          swap( heap(a4+j), heap(temp+j) );
     624      end do;
     625
     626      $ swap parameters
     627      temp = last_env + 4 + a5 + 2;
     628      do j = 0 to a3-1;
     629          swap( heap(a2+j), heap(temp+j) );
     630      end do;
     631
     632      $ change the exit block back into an entry block
     633      value(last_env)   = a1;
     634
     635      $ now that we have converted the 'exit' block to an 'entry' block,
     636      $ we must move it to the right place in the list of environments.
     637
     638      cur_env  = last_env;
     639      last_env = value(cur_env+1);
     640      prev_env = value(cur_env+3);
     641
     642      value(cur_env+1)  = value(prev_env+1);
     643      value(cur_env+3)  = 0;
     644      value(prev_env+1) = cur_env;
     645
     646      codep    = value(last_env);
     647      return;
     648
     649
     650/case(q2_fail2)/              $ fail
     651
     652$ this instruction pops the values saved by a q2_ok instruction and
     653$ branches to the saved address.
     654
     655      $ pop environment block
     656      last_env = value(last_env+1);
     657      free_stack(3);
     658
     659      $ save the current code pointer
     660      p = codep;
     661
     662      $ get the return address to the instruction after the q2_ok
     663      pop1(t1);
     664      codep = value_ t1;
     665
     666      $ restore the save variables
     667      do j = 0 to a2-1;
     668          p = p + inst_nw;
     669          heap(codea1(p)) = heap(t+j);
     670      end do;
     671      free_stack(a2);   savet = t;
     672
     673      $ that guess was not 'ok'
     674      heap(s_okval) = heap(s_false);
     675
     676      return;
     677
     678
     679/case(q2_succeed)/            $ succeed
     680
     681$ this opcode wipes out all saved environments up to and  including  the
     682$ last 'ok'.
     683
     684      if (ok_lev = 0) call err_fatal(48);
     685      ok_lev = ok_lev - 1;
     686
     687$ if we follow the chain of environments starting with last_env we  will
     688$ find:
     689$
     690$ 1. a series of entry and exit blocks
     691$ 2. an ok block
     692$ 3. another block
     693$
     694$ we proceed down the chain, deleting 'exit' and 'ok' blocks.   when  we
     695$ find an 'ok' block, we quit the loop.
     696$
     697$ in the loop which follows we have:
     698$
     699$ cur_env:   points to block being processed
     700$ prev_env:  points to previous environment
     701$ last_env:  points to head of list
     702$
     703$ t1:        opcode for instruction at value(cur_env)
     704$ t2:        points to next block
     705$ t3:        number of saved specifiers in current block
     706
     707      cur_env  = last_env;
     708      prev_env = 0;
     709
     710      until t1 = q2_fail2;    $ until we have processed the first ok
     711
     712          t1 = codeop(value(cur_env));  $ saved opcode
     713          t2 = value(cur_env+1);        $ next environment
     714          t3 = value(cur_env+2);        $ number of saved values
     715
     716          if t1 = q2_dexit then         $ skip entry block
     717              prev_env = cur_env;   cur_env  = t2;
     718              cont until;
     719          end if;
     720
     721          $ delete the block
     722          do j = 1 to cur_env-t;
     723              heap(cur_env+t3+3-j) = heap(cur_env-j);
     724          end do;
     725          free_stack(t3+3);
     726
     727          $ update pointers to next environment and previous environment
     728          $ then link the previous environment to the next one.
     729          if (t2 ^= 0 & t2 < cur_env)         t2 = t2+t3+3;
     730          if (prev_env^=0 & prev_env< cur_env then
     739              last_env = last_env+t3+3;
     740          end if;
     741
     742          $ now iterate over entire list of environments to insure  that
     743          $ all pointers are valid.
     744          cur_env = last_env;
     745          while cur_env ^= 0;
     746              p1 = value(cur_env+1);
     747              if (p1 ^= 0 & p1 < cur_env) value(cur_env+1) = p1+t3+3;
     748              if t1 = q2_undo then
     749                  p1 = value(cur_env+3);
     750                  if (p1 < cur_env) value(cur_env+3) = p1+t3+3;
     751              end if;
     752
     753              cur_env = value(cur_env+1);
     754          end while;
     755
     756          $ advance to next block
     757          cur_env = t2;
     758      end until;
     759
     760      go to nxt;
     761
     762
     763/case(q2_open)/
     764
     765      heap(a1) = sopen(value(a3));
     766      go to nxt;
     767
     768
     769/case(q2_close)/     $ close
     770
     771      heap(a1) = sclose(value(a3));
     772      go to nxt;
     773
     774
     775/case(q2_print)/  $ print
     776
     777      heap(a1) = print(value(a3));
     778      go to nxt;
     779
     780
     781/case(q2_read)/  $ read
     782
     783      heap(a1) = readr(value(a3));
     784      go to nxt;
     785
     786
     787/case(q2_printa)/  $ printa
     788
     789      heap(a1) = printa(value(a3));
     790      go to nxt;
     791
     792
     793/case(q2_reada)/  $ reada
     794
     795      heap(a1) = reada(value(a3));
     796      go to nxt;
     797
     798
     799/case(q2_get)/  $ get
     800
     801      heap(a1) = getr(value(a3));
     802      go to nxt;
     803
     804
     805/case(q2_put)/  $ put
     806
     807      heap(a1) = putr(value(a3));
     808      go to nxt;
     809
     810
     811/case(q2_getb)/  $ getb
     812
     813      heap(a1) = getb(value(a3));
     814      go to nxt;
     815
     816
     817/case(q2_putb)/  $ putb
     818
     819      heap(a1) = putb(value(a3));
     820      go to nxt;
     821
     822
     823/case(q2_getk)/  $ getk
     824
     825      heap(a1) = getk(value(a3));
     826      go to nxt;
     827
     828
     829/case(q2_putk)/  $ putk
     830
     831      heap(a1) = putk(value(a3));
     832      go to nxt;
     833
     834/case(q2_getf)/       $ getf
     835
     836      heap(a1) = getf(value(a3));
     837      go to nxt;
     838
     839/case(q2_callf)/              $ callf
     840
     841      heap(a1) = callf(ivalue(a3));
     842      go to nxt;
     843
     844
     845/case(q2_putf)/       $ putf
     846
     847      heap(a1) = putf(value(a3));
     848      go to nxt;
     849
     850
     851/case(q2_rewind)/  $ rewind
     852
     853      heap(a1) = rewindr(value(a3));
     854      go to nxt;
     855
     856
     857/case(q2_eof)/  $ eof
     858
     859      heap(a1) = eof(value(a3));
     860      go to nxt;
     861
     862
     863/case(q2_host)/
     864
     865      heap(a1) = shost(ivalue(a3));
     866      go to nxt;
     867
     868
     869/case(q2_eject)/   $ eject
     870
     871      heap(a1) = eject(value(a3));
     872      go to nxt;
     873
     874
     875/case(q2_titl)/    $ title
     876
     877      heap(a1) = title(value(a3));
     878      go to nxt;
     879
     880
     881/case(q2_getipp)/     $ get integer control card parameter
     882
     883      heap(a1) = sgtipp(value(a3));
     884      go to nxt;
     885
     886
     887/case(q2_getspp)/     $ get string control card parameter
     888
     889      heap(a1) = sgtspp(value(a3));
     890      go to nxt;
     891
     892
     893/case(q2_getem)/      $ get error mode and limit
     894
     895      heap(a1) = getem(value(a3));
     896      go to nxt;
     897
     898
     899/case(q2_setem)/     $ set error mode and limit
     900
     901      heap(a1) = setem(value(a3));
     902      go to nxt;
     903
     904
     905
     906/case(q2_span)/  $ span
     907
     908      heap(a1) = span(value(a3));
     909      go to nxt;
     910
     911
     912/case(q2_break)/  $ break
     913
     914      heap(a1) = break(value(a3));
     915      go to nxt;
     916
     917
     918/case(q2_match)/              $ match
     919
     920      heap(a1) = match(value(a3));
     921      go to nxt;
     922
     923
     924/case(q2_lpad)/
     925
     926      heap(a1) = lpad(value(a3));
     927      go to nxt;
     928
     929
     930/case(q2_len)/                $ len
     931
     932      heap(a1) = len(ivalue(a3));       go to nxt;
     933
     934
     935/case(q2_any)/  $ any
     936
     937      heap(a1) = sany(value(a3));
     938      go to nxt;
     939
     940
     941/case(q2_notany)/  $ notany
     942
     943      heap(a1) = notany(value(a3));
     944      go to nxt;
     945
     946
     947/case(q2_rspan)/  $ rspan
     948
     949      heap(a1) = rspan(value(a3));
     950      go to nxt;
     951
     952
     953/case(q2_rbreak)/  $ rbreak
     954
     955      heap(a1) = rbreak(value(a3));
     956      go to nxt;
     957
     958
     959/case(q2_rmatch)/             $ rmatch
     960
     961      heap(a1) = rmatch(value(a3));
     962      go to nxt;
     963
     964
     965/case(q2_rpad)/
     966
     967      heap(a1) = rpad(value(a3));
     968      go to nxt;
     969
     970
     971/case(q2_rlen)/               $ rlen
     972
     973      heap(a1) = rlen(ivalue(a3));      go to nxt;
     974
     975
     976/case(q2_rany)/  $ rany
     977
     978      heap(a1) = rany(value(a3));
     979      go to nxt;
     980
     981
     982/case(q2_rnotany)/  $ rnotany
     983
     984      heap(a1) = rnotany(value(a3));
     985      go to nxt;
     986
     987
     988
     989
     990
     991$ section 9 - debugging and monitor operations
     992
     993
     994/case(q2_tre)/       $ enable/disable entry trace
     995
     996      monitor entry, limit = 10000;
     997      go to nxt;
     998
     999
    1000/case(q2_notre)/    $ disbale entry trace
    1001
    1002      monitor noentry;
    1003      go to nxt;
    1004
    1005
    1006/case(q2_trcstmts)/           $ trace statements:  a1 indicates on/off
    1007
    1008      trace_stmts = ivalue(a1);
    1009      go to nxt;
    1010
    1011
    1012/case(q2_trccalls)/           $ trace calls: a1 indicates on/off
    1013
    1014      trace_calls = ivalue(a1);
    1015      go to nxt;
    1016
    1017
    1018/case(q2_trcsym)/             $ trace a1, a2 indicates on/off
    1019
    1020      if debug_flag & ^ is_om(s_rnspec) then
    1021          pt11comp(value(s_rnspec), a1-sym_org+1) = ivalue(a2);
    1022      end if;
    1023      go to nxt;
    1024
    1025
    1026/case(q2_trc)/  $ enable code trace
    1027
    1028 .+ct ctrace = yes;
    1029      go to nxt;
    1030
    1031
    1032/case(q2_notrc)/  $ disable code trace
    1033
    1034 .+ct ctrace = no;
    1035      go to nxt;
    1036
    1037
    1038/case(q2_trg)/   $ trace garbage collections
    1039
    1040 .+gt gtrace = yes;
    1041      go to nxt;
    1042
    1043
    1044/case(q2_notrg)/  $ disable garbage collecor trace
    1045
    1046 .+gt gtrace = no;
    1047      go to nxt;
    1048
    1049
    1050/case(q2_gdump)/   $ enable dumps during garbage collection
    1051
    1052 .+gt gdump = yes;
    1053      go to nxt;
    1054
    1055
    1056/case(q2_nogdump)/  $ disable dumps during garbage collection
    1057
    1058 .+gt gdump = no;
    1059      go to nxt;
    1060
    1061
    1062/case(q2_dump)/  $ dump storage
    1063
    1064      if (snap_flag) call snap(codep - 2*inst_nw);
    1065
    1066      codep = codep + inst_nw;
    1067
    1068      call dumpds1;
    1069      return;
    1070
    1071
    1072/case(q2_garb)/   $ invoke garbage collector
    1073
    1074
    1075$ note that the garbage collector never returns to the point
    1076$ where it was called; instead it reinvokes the interpreter,
    1077$ which repeats its last instruction. this would be disasterous
    1078$ here since it would cause us to loop over the garbage collector
    1079$ call. thus before we call the garbage collector we must advance
    1080$ the interpreter to its next instruction.
    1081
    1082      codep = codep + inst_nw;
    1083
    1084      call grbcol;
    1085      assert 0;
    1086
    1087/case(q2_stmt)/     $ statement trace
    1088
    1089      if trace_stmts then
    1090          put ,'start statement ' :a2,i ,' of ' :var_id(a1, 0),a ,skip;
    1091      end if;
    1092
    1093 .+st add_stat(st_space, (h - stmt_h));
    1094
    1095 .+st cur_stmt = a3;
    1096 .+st stmt_h   = h;
    1097
    1098 .+st add_stat(st_count, 1);
    1099
    1100      stm_exe = stm_exe + 1; $ count statements executed
    1101      go to nxt;
    1102
    1103
    1104
    1105
    1106
    1107$ and finally, since this madness cant go on forever....
    1108
    1109$ section 11 - termination
    1110
    1111/case(q2_abort)/     $ abort
    1112
    1113      call err_misc(24);
    1114      go to case(q2_stop);
    1115
    1116
    1117/case(q2_error)/              $ compile time error
    1118
    1119      call err_misc(48);
    1120
    1121
    1122/case(q2_stop)/
    1123
    1124
    1125$ calculate total execution time
    1126      call letime(temp);
    1127      temp = temp - entry_time;
    1128
    1129$ the measurement package will have to allocate a tuple to collect
    1130$ frequency statistics. make sure there is space available before
    1131$ leaving the interpreter. we will need room for a tuple with
    1132$ q2_maximum elements.
    1133
    1134 .+st  reserve(talloc(q2_maximum + breath_space(q2_maximum)));
    1135
    1136      call libterm(temp);
    1137
    1138
    1139/case(q2_noop)/
    1140
    1141$ this opcode is used only for quadruples which hold extra
    1142$ arguments for the previous instruction. intstructions
    1143$ with more than three arguments should always skip over
    1144$ the appropriate number of noop instructions, and thus
    1145$ this opcode should never be executed.
    1146
    1147      call err_fatal(4);
    1148
    1149
    1150/nxt/       $ advance code pointer and return
    1151
    1152      codep = codep+inst_nw;
    1153
    1154
    1155      end subr intrp4;
    1156
    1157 .+tr trace entry;            $ restore entry trace
    1158
    1159 ..part1
       1 .=member equal
       2 .+part2.
       3
       4
       5      fnct equal(arg1, arg2);
       6
       7$ this routine compares a pair of setl values for equality. since
       8$ setl data structures are themselves recursive, this routine
       9$ provides its own recursion.
      10
      11$ results
      12
      13$ from a purists point of view, -equal- should return the setl
      14$ constants -true- and -false-. however, equal will usually be
      15$ called as part of a conditional branch. it is considerably faster
      16$ to branch an zero/non-zero than it is to branch on these setl
      17$ constants. for this reason we return 1 for true and 0 for false.
      18$ for setl statements such as
      19$
      20$                  a := b = c;
      21$
      22$ we will compile in-line code to convert 0-1 into false-true.
      23
      24
      25$ inline tests
      26
      27$ certain tests are performed inline before calling the equality
      28$ routine. these same tests are performed inline within the equality
      29$ routine before making a recursive call. these consist of a comparison
      30$ of the otvalue fields(using the -eq- macro) and a test for two
      31$ short type codes(using the -ne- macro). these tests are decisive
      32$ when comparing pairs of short items.
      33
      34
      35$ algorithm
      36
      37$ upon reaching the label -entry- , a1 and a2 are specifiers for two
      38$ values which are not trivially equal or unequal. we first
      39$ dereference them and repeat the inline equality checks. if these
      40$ are not decisive we check whether both inputs have matching
      41$ primitive types. if so we call -eqprim- to compare them. other-
      42$ wise if both are tuples we jump to 'case(eq_tup)';  if both are
      43$ sets we jump to 'case(eq_set)';  otherwise we fail.
      44
      45
      46      size equal(1);          $ boolean value returned
      47
      48      size arg1(hs);          $ specifier for first input
      49      size arg2(hs);          $ specifier for second input
      50
      51      size a1(hs);            $ specifier for first argument
      52      size a2(hs);            $ specifier for second argument
      53
      54      size tstart(ps);        $ pointer to recursion stack at start
      55
      56      size hashc(ps);         $ hash code rerurned by init_probe
      57      size head(ps);          $ pointer returned by init_probe
      58      size val(hs);           $ packed value
      59
      60      size n(ps);             $ nelt of tuples being compared
      61
      62      size t1(ps);            $ types of things being compared
      63      size t2(ps);
      64
      65      $ non-recursive variables for the first argument
      66      size st1(ps);           $ pointer to data block
      67      size hash1(hcsz);       $ hash code
      68      size ht1(ps);           $ pointer to hash table
      69      size log1(ps);          $ log(number of hash headers)
      70      size tmp1(ps);          $ pointer to template
      71      size e1(ps);            $ pointer to current element block
      72
      73      $ non-recursive variables for the second argument
      74      size st2(ps);           $ pointer to data block
      75      size hash2(hcsz);       $ hash code
      76      size ht2(ps);           $ pointer to hash table
      77      size log2(ps);          $ log(number of hash headers)
      78      size tmp2(ps);          $ pointer to template
      79      size e2(ps);            $ pointer to current element block
      80
      81      $ non-recursive variables for based set comparisons
      82      size bit(ps);           $ ls_bit of local set
      83      size word(ps);          $ ls_word of local set
      84      size indx(ps);          $ ebindx of remote set
      85      size maxi(ps);          $ rs_maxi of remote set
      86
      87      $ non-recursive variables for set/map case
      88      size temp(hs);          $ heap sized temporary
      89      size p(ps);             $ pointer to range set
      90
      91      $ subroutines to handle various special cases
      92      size eqprim(1);
      93      size eqtup1(1), eqtup2(1), eqtup3(1), eqtup4(1);
      94      size eqrs(1),   eqls(1),   eqlrs(1);
      95
      96      size nullp(1);
      97      size fval(hs);          $ returns function value of mapping
      98      size gethash(hcsz);     $ computes hasc code
      99      size convut(hs);        $ converts untyped tuples
     100      size arb1(hs);          $ arbitrary element from range set
     101
     102$ stacked variables
     103
     104 .=zzyorg b     $ reset counters for stack offsets
     105
     106      local(retpt);           $ return pointer
     107
     108      local(p1);              $ pointers to tuple components
     109      local(p2);
     110
     111      local(plim);            $ limit for p1 in tuple loops
     112
     113      local(bpos);            $ bit position in packed tuple
     114      local(pbits);           $ bits per packed value
     115      local(pkey)             $ key for packed tuple
     116
     117      $ recursive variables for set and map comparisons
     118      local(sameb);           $ flags two sets on same base
     119      local(dsize);           $ difference in hash table sizes
     120      local(dcntr);           $ current difference
     121
     122      $ recursive variables for first set
     123      local(set1);            $ pointer to set
     124      local(head1);           $ pointer to hash header
     125      local(elmt1);           $ pointer to current element block
     126      local(off1);            $ word offsets in local map
     127
     128      $ recursive variables for second set
     129      local(set2);            $ pointer to set
     130      local(head2);           $ pointer to hash header
     131      local(elmt2);           $ pointer to current element block
     132      local(off2);            $ word offsets in local map
     133
     134      local(iter);            $ specifier returned by -next-
     135      local(map);             $ specifier for map passed to nexts
     136
     137
     138
     139      a1 = arg1;   a2 = arg2; $ copy arguments
     140
     141      tstart = t;             $ initilize for recursion
     142
     143 .=zzyorg a     $ reset counter for return labels
     144
     145
     146/entry/                       $ recursive entry point
     147
     148      r_entry;   $ increment recursion stack
     149
     150
     151$ the obvious thing to do upon entering the recursive routine is  a
     152$ jump on the types of the two operands.  this hump, however, would
     153$ be quite monsterous.  there are  1024 combinations of type  codes
     154$ leading to a mere 6 cases in the equality routine.   the best way
     155$ to  handle such a jump table would be to use an auxiliary  matrix
     156$ mapping types to cases.  not only would this table be very large,
     157$ but  the whole correctness of the equality  routine would  depend
     158$ on the accuracy with which it was initialized.
     159$
     160$ instead we do two smaller jumps.  the first jump is on the number
     161$ of inputs which have their is_om bits set.  this weeds out enough
     162$ cases so that the second jump can be on the cross product of long
     163$ defined types.  the matrix for this turns out to be fairly small,
     164$ and more important,  it can be initialized in a very simple,  me-
     165$ chanical fashion. this should result in much less bug prone code.
     166
     167      if (is_om_ a1 ^= is_om_ a2) go to fail;
     168      if (is_om_ a1) go to pass;
     169
     170
     171/switch/                      $ jump on types
     172
     173      t1 = otype_ a1;   t2 = otype_ a2;
     174
     175      go to case(eq_case(t1, t2)) in eq_fail to eq_set;
     176
     177
     178/case(eq_fail)/               $ incompatible types
     179
     180      go to fail;
     181
     182
     183/case(eq_prim)/      $ long objects of same primitive type
     184
     185      equal = eqprim(a1, a2);   go to exit;
     186
     187
     188/case(eq_elmt)/      $ two elements
     189$
     190$ if a1 and a2 point to element base blocks of the same base,  then
     191$ they must be unequal;  otherwise,  dereference and start anew.
     192$
     193      e1 = value_ a1;   e2 = value_ a2;
     194
     195      if htype(e1) = h_ebb & htype(e2) = h_ebb then
     196          if (ebform(e1) = ebform(e2)) go to fail;
     197      end if;
     198
     199
     200/case(eq_deref)/          $ dererence elements
     201
     202      deref(a1);   deref(a2);
     203
     204      if (eq(a1, a2)) go to pass;
     205      if (ne(a1, a2)) go to fail;
     206
     207      go to switch;
     208
     209
     210$     r e c u r s i v e    c a s e s
     211$     -----------------    ---------
     212
     213
     214/case(eq_tup)/                $ tuple cases
     215
     216$ we begin by comparing their lengths, then there hashes(if valid).
     217$ if these agree, we compare their elements.
     218
     219      st1 = value_ a1;   st2 = value_ a2;
     220
     221      n = nelt(st1);   if (n ^= nelt(st2)) go to fail;
     222
     223      if is_hashok(st1) & is_hashok(st2) then
     224          if (hash(st1) ^= hash(st2)) go to fail;
     225      end if;
     226
     227$ special case by the types of the tuples.
     228
     229      t1 = htype(st1);   t2 = htype(st2);
     230
     231      deflab(tc, h_tuple, h_rtuple);  $ define labels for case jump
     232
     233      go to tc(t1, t2) in minlab to maxlab;
     234
     235
     236/tc(h_tuple, h_tuple)/        $ tuple(*) = tuple(*)
     237
     238      p1 = st1 + compoffs(1);   plim = st1 + compoffs(n);
     239      p2 = st2 + compoffs(1);
     240
     241      while p1 <= plim;
     242          a1 = heap(p1);   p1 = p1 + 1;
     243          a2 = heap(p2);   p2 = p2 + 1;
     244
     245          if (eq(a1, a2)) cont while;
     246          if (ne(a1, a2)) go to fail;
     247          r_call;
     248          if (^ equal) go to fail;
     249      end while;
     250
     251      go to pass;
     252
     253
     254/tc(h_ptuple, h_tuple)/       $ packed tuple(?) = tuple(*)
     255
     256      swap(st1, st2)          $  -  swap arguments, go to next case
     257
     258
     259/tc(h_tuple, h_ptuple)/       $ tuple(*) = packed tuple(?)
     260$
     261$ packed tuples may contain integers  and  elements of constant ba-
     262$ ses.   since a constant base may have sets or tuples of constants
     263$ as elements,  we must be prepared to do recursive tests on packed
     264$ objects.
     265$
sunb  32    /****** disable code that causes ltlasm to abort ******
     266      pkey = ptkey(st2);   pbits = ptbits(st2);
     267      p1 = st1 + compoffs(1);   plim = st1 + compoffs(n);
suna  37      p2 = st2 + packoffs(st2, 1);   bpos = 1;
     269
     270      while p1 <= plim;
     271          a1 = heap(p1);   p1 = p1 + 1;
     272
suna  38          val = .f. bpos, pbits, heap(p2);   unpack(pkey, val, a2);
     273          bpos = bpos + pbits;
     274          if bpos > bpos_max then p2 = p2 + 1; bpos = 1; end if;
     276
     277          if (eq(a1, a2)) cont while;
     278          if (ne(a1, a2)) go to fail;
     279          r_call;
     280          if (^ equal) go to fail;
     281      end while;
     282
     283      go to pass;
sunb  33    ******/
     284
     285
     286
     287$ the following cases are non-recursive and can be done offline.
     288$ note that the comparison of two packed tuples is recursive if
     289$ they do not have the same packing key.
     290
     291/tc(h_ptuple, h_ptuple)/      $ packed tuple(?) = packed tuple(?)
     292
     293      if ptkey(st1) = ptkey(st2) then  $ do off line
     294          equal = eqtup1(a1, a2);
     295
     296      else  $ unpack a1 and start again.
     297          a1 = convut(a1, f_tuple);
     298          go to case(eq_tup);
     299      end if;
     300
     301      go to exit;
     302
     303
     304/tc(h_tuple, h_rtuple)/       $ tuple(*) = tuple(untyped real)
     305
     306      equal = eqtup2(a2, a1);   go to exit;
     307
     308
     309/tc(h_rtuple, h_tuple)/       $ tuple(untyped real) = tuple(*)
     310
     311      equal = eqtup2(a1, a2);   go to exit;
     312
     313
     314/tc(h_ituple, h_tuple)/       $ tuple(untyped integer) = tuple(*)
     315
     316      equal = eqtup3(a2, a1);   go to exit;
     317
     318
     319/tc(h_tuple, h_ituple)/       $ tuple(*) = tuple(untyped integer)
     320
     321      equal = eqtup3(a1, a2);   go to exit;
     322
     323
     324/tc(h_rtuple, h_rtuple)/      $ untyped tuples of same component mode
     325
     326/tc(h_ituple, h_ituple)/
     327
     328      equal = eqtup4(a1, a2);   go to exit;
     329
     330
     331/tc(h_rtuple, h_ituple)/      $ mismatched tuples
     332
     333/tc(h_ituple, h_rtuple)/
     334
     335      go to fail;
     336
     337
     338/tc(h_ptuple, h_ituple)/      $ packed tuple(?) = tuple(untyped integer)
     339
     340/tc(h_ptuple, h_rtuple)/      $ packed tuple(?) = tuple(untyped real)
     341
     342$ convert a2 to a standard tuple, then use a more common case.
     343$ note that we will call a conversion routine which does not in
     344$ turn call the equality routine.
     345
     346      a2 = convut(a2, f_tuple);
     347      go to tc(h_ptuple, h_tuple);
     348
     349
     350/tc(h_ituple, h_ptuple)/      $ tuple(untyped integer) = packed tuple(?)
     351
     352/tc(h_rtuple, h_ptuple)/      $ tuple(untyped real) = packed tuple(?)
     353
     354      a1 = convut(a1, f_tuple);
     355      go to tc(h_tuple, h_ptuple);
     356
     357
     358
     359
     360/case(eq_set)/                $ set and map cases
     361$
     362$ our algorithm is as follows:
     363$
     364$ 1. test the cardinalities for equality
     365$ 2. update and compare their hash codes
     366$ 3. compare their elements recursively
     367$
     368      st1 = value_ a1;   st2 = value_ a2;
     369
     370      if is_neltok(st1) & is_neltok(st2) then
     371          if (nelt(st1) ^= nelt(st2)) go to fail;
     372      end if;
     373
     374      if is_hashok(st1) & is_hashok(st2) then
     375          if (hash(st1) ^= hash(st2)) go to fail;
     376      end if;
     377$
     378$ separate various classes of element comparison
     379$
     380      t1 = htype(st1);   t2 = htype(st2);
     381
     382      if (is_map(st1) ^= is_map(st2)) go to set_map;
     383      if (is_map(st1))                go to map_case;
     384$
     385$ set cases
     386$
     387      $ special case two sets on a common base
     388      sameb = is_elset(st1) & is_elset(st2) &
     389                  ft_elmt(hform(st1)) = ft_elmt(hform(st2));
     390
     391      if ^ (sameb = yes & is_based(st1) & is_based(st2)) then
     392          if (^ is_neltok(st1)) call okneltr(a1);
     393          if (^ is_neltok(st2)) call okneltr(a2);
     394          if (nelt(st1) ^= nelt(st2)) go to fail;
     395      end if;
     396
     397      deflab(sc, h_uset, h_rset);
     398
     399      if sameb then
     400          go to sc(t1, t2) in minlab to maxlab;
     401      end if;
     402
     403
     404/general_set/                 $ general set case
     405$
     406$ to compare two sets in general, we use the following algorithm:
     407$
     408$ 1. compare the size of the two hash tables,  and  interchange the
     409$    the sets if the hash table of the second set  is  larger  than
     410$    the hash table of the first set.
     411$
     412$ 2. let dsize be the power of two of the  difference  of the loga-
     413$    rithms of the respective hash table sizes.  this number  gives
     414$    the number of clash lists in the larger hash table which  cor-
     415$    respond to each clash list in the smaller hash table.
     416$
     417$ 3. iterate  over  consequtive  clash lists of the first set.   if
     418$    there  does not exist a new clash list, go to step 6;   other-
     419$    wise, proceed with step 4.
     420$
     421$ 4. search for each element e1 in the clash list of the first  set
     422$    in the current clash list of the second set.   return false if
     423$    the element is not found.
     424$
     425$ 5. advance in the first set.  if there exists an other element e1
     426$    in the current clash list, go to step 4.  otherwise, conditio-
     427$    nally advance to the next clash list in the  second  set,  and
     428$    go to step 3.
     429$
     430$ 6. at this point, the two sets must be equal:  return true.
     431$
     432      ht1 = hashtb(st1);   ht2 = hashtb(st2);
     433
     434      log1 = lognhedrs(ht1);  $ get log of hash table size
     435      log2 = lognhedrs(ht2);
     436
     437      dsize = pow2(iabs(log1 - log2));
     438      dcntr = dsize;
     439
     440      if log1 < log2 then
     441          swap(st1, st2)
     442          swap(ht1, ht2)
     443      end if;
     444
     445      tmp1  = ht1 + hl_ht;    $ pointer to template
     446      e1    = eblink(tmp1);   $ pointer to first hash header
     447
     448      tmp2  = ht2 + hl_ht;    $ pointer to template of st2
     449      head2 = eblink(tmp2);   $ pointer to the first hash header
     450
     451      until is_ebtemp(e1);
     452          until is_ebhedr(e1);
     453              e1 = eblink(e1);
     454
     455              if (is_ebhedr(e1)) quit until;
     456
     457              if is_based(st1) then   $ check subset membership
     458                  if (fval(st1, e1, no) = no) cont until;
     459              end if;
     460
     461              equal = no;     $ initialize for comparison
     462          $
     463          $ look for e1 in the second set
     464          $
     465              e2 = head2;
     466              until is_ebhedr(e2);
     467                  e2 = eblink(e2);
     468
     469                  if (is_ebhedr(e2)) quit until;
     470
     471                  if is_based(st2) then    $ check subset membership
     472                      if (fval(st2, e2, no) = no) cont until;
     473                  end if;
     474
     475                  a1 = ebspec(e1);   a2 = ebspec(e2);
     476
     477                  if eq(a1, a2) then equal = yes; quit until; end;
     478                  if (ne(a1, a2))                 cont until;
     479                  if (sameb)                      cont until;
     480
     481                  set1 = st1;  set2 = st2;  elmt1 = e1;  elmt2 = e2;
     482                  r_call;
     483                  st1 = set1;  st2 = set2;  e1 = elmt1;  e2 = elmt2;
     484
     485                  if (equal) quit until;
     486              end until;
     487
     488              if (^ equal) go to fail;
     489          end until;
     490      $
     491      $ we might have to update the hash header pointer into st2
     492      $
     493          if dcntr > 1 then
     494              dcntr = dcntr - 1;
     495          else
     496              dcntr = dsize;   head2 = head2 + hl_htb;
     497          end if;
     498
     499      end until;
     500
     501      go to pass;
     502
     503
     504
     505$ special cases for sets on a common base
     506
     507/sc(h_uset, h_uset)/          $ sparse set(elmt b) = sparse set(elmt b)
     508
     509      go to general_set;      $  -  use general set loop
     510
     511
     512/sc(h_rset, h_rset)/          $ remote set(elmt b) = remote set(elmt b)
     513
     514      equal = eqrs(a1, a2);   go to exit;
     515
     516
     517/sc(h_lset, h_lset)/          $ local set(elmt b) = local set(elmt b)
     518
     519      equal = eqls(a1, a2);   go to exit;
     520
     521
     522/sc(h_lset, h_rset)/          $ local set(elmt b) = remote set(elmt b)
     523
     524      equal = eqlrs(a1, a2);  go to exit;
     525
     526/sc(h_rset, h_lset)/          $ remote set(elmt b) = local set(elmt b)
     527
     528      equal = eqlrs(a2, a1);  go to exit;
     529
     530
     531/sc(h_rset, h_uset)/          $ remote set(elmt b) = sparse set(elmt b)
     532
     533      swap(st1, st2)          $  -  swap and go on to next case
     534
     535
     536/sc(h_uset, h_rset)/          $ sparse set(elmt b) = remote set(elmt b)
     537
     538$ iterate over unbased set, getting pointers into the base, and
     539$ checking membership in the based set.
     540
     541      maxi = rs_maxi(st2);
     542      next_loop(e1, st1);
     543          indx = ebindx(value_ ebspec(e1)); if (indx > maxi) go to fail;
     544          if (^ rsbit(st2, indx)) go to fail;
     545      end_next;
     546
     547      go to pass;
     548
     549
     550/sc(h_lset, h_uset)/          $ local set(elmt b) = sparse set(elmt b)
     551
     552      swap(st1, st2);
     553
     554
     555/sc(h_uset, h_lset)/          $ sparse set(elmt b) = local set(elmt b)
     556
     557      bit = ls_bit(st2);   word = ls_word(st2);
     558
     559      next_loop(e1, st1);
     560          if ^ (.f. bit, 1, heap(value_ ebspec(e1) + word)) then
     561              go to fail;
     562          end if;
     563      end_next;
     564
     565      go to pass;
     566
     567
     568
     569/map_case/                    $ map cases
     570
     571$ map the types of the two maps into their maptype-s, which
     572$ indicate unbased, local, or remote. then see whether both maps
     573$ are on the same base. if so, jump to a special case.
     574
     575      sameb = is_elset(st1) & is_elset(st2) &
     576                  ft_dom(hform(st1)) = ft_dom(hform(st2));
     577
     578      if ^ (sameb = yes & is_based(st1) & is_based(st2)) then
     579          if (^ is_neltok(st1)) call okneltr(a1);
     580          if (^ is_neltok(st2)) call okneltr(a2);
     581          if (nelt(st1) ^= nelt(st2)) go to fail;
     582      end if;
     583
     584      deflab(mc, m_umap, m_lmap);   $ define labels for special cases
     585
     586      if sameb then
     587          t1 = maptype(t1);
     588          t2 = maptype(t2);
     589
     590          go to mc(t1, t2) in minlab to maxlab;
     591      end if;
     592
     593
     594/general_map/          $ general case
     595
     596$ otherwise compare the hash tables of the two sets for matching
     597$ elements.
     598
     599$ the loop which follows is similar to the general loop for comparing
     600$ two sets. the difference is that having found two matching domain
     601$ elements, we must go on to compare their images.
     602
     603$ commute arguments if necessary so set1 has the larger hash table
     604
     605      ht1 = hashtb(st1);      $ get pointers to hash tables
     606      ht2 = hashtb(st2);
     607
     608      log1 = lognhedrs(ht1);  $ get log of hash table size
     609      log2 = lognhedrs(ht2);
     610
     611      if log1 < log2 then
     612          swap(st1, st2)
     613          swap(ht1, ht2)
     614          swap(log1, log2)
     615      end if;
     616
     617      dsize = pow2(log1-log2);
     618      dcntr = dsize;
     619
     620      tmp1 = ht1 + hl_ht;     $ get pointers to templates
     621      tmp2 = ht2 + hl_ht;
     622
     623      head1 = eblink(tmp1);   $ get pointers to first hash headers
     624      head2 = eblink(tmp2);
     625
     626      while ^ is_ebtemp(head1);
     627      $
     628      $ iterate over the clash list of the first set
     629      $
     630          probe_loop(e1, head1);
     631
     632              equal = no;     $ initialize for comparison
     633          $
     634          $ look for e1 in then second set
     635          $
     636              probe_loop(e2, head2);
     637
     638              $
     639              $ compare e1 and e2
     640              $
     641                  a1 = ebspec(e1);      $ get heap words
     642                  a2 = ebspec(e2);
     643
     644                  if eq(a1, a2) then equal = yes; quit_probe; end;
     645                  if (ne(a1, a2))                 cont_probe;
     646                  if (sameb)                      cont_probe;
     647
     648                  set1 = st1;  set2 = st2;  elmt1 = e1;  elmt2 = e2;
     649                  r_call;
     650                  st1 = set1;  st2 = set2;  e1 = elmt1;  e2 = elmt2;
     651
     652                  if (equal) quit_probe;
     653
     654              end_probe;
     655          $
     656          $ if e1 is not in the domain of st2, check whether the
     657          $ image of e1 is non-trivial
     658          $
     659              if ^ equal then  $ no match
     660
     661                  a1 = fval(st1, e1, no);
     662
     663                  if is_multi_ a1 then  $ look for null range set
     664                      p = value_ a1;
     665
     666                      if is_neltok(p) then
     667                          if (nelt(p) = 0) cont_probe;
     668                      else
     669                          if (nullp(p)) cont_probe;
     670                      end if;
     671
     672                  else
     673                      if (is_om_ a1) cont_probe;
     674                  end if;
     675
     676                  go to fail;   $ image is defined
     677              end if;
     678          $
     679          $ compare images of corresponding domain elements
     680          $
     681              a1 = fval(st1, e1, no);         $ get images.
     682              a2 = fval(st2, e2, no);
     683
     684              $ compare is_multi_ bits:  standardize images
     685              if is_multi_ a1 ^= is_multi_ a2 then
     686                  l_call(std);   if (^ equal) go to fail;
     687              end if;
     688
     689              $ is_multi_ bits match:  compare values
     690              if (eq(a1, a2)) cont_probe;
     691              if (ne(a1, a2)) go to fail;
     692
     693              set1 = st1;  set2 = st2;  elmt1 = e1;  elmt2 = e2;
     694              r_call;
     695              st1 = set1;  st2 = set2;  e1 = elmt1;  e2 = elmt2;
     696
     697              if (^ equal) go to fail;
     698
     699          end_probe;
     700      $
     701      $ move to the next hash header in st1.   conditionally move to
     702      $ the next hash header in st2
     703      $
     704          head1 = e1;         $ e1 points to the next hash header
     705
     706          if dcntr > 1 then
     707              dcntr = dcntr - 1;
     708          else
     709              dcntr = dsize;   head2 = head2 + hl_htb;
     710          end if;
     711
     712      end while;
     713
     714      go to pass;
     715
     716
     717
     718
     719$ special cases for maps
     720
     721
     722/mc(m_umap, m_umap)/          $ two unbased maps
     723
     724      go to general_map;      $    use general map case
     725
     726
     727/mc(m_rmap, m_rmap)/          $ remote maps on same base
     728$
     729$ two compare two remote maps is equivalent to comparing their embedded
     730$ tuples.  these tuples, however, are unusual in two respects:
     731$ a. their nelt field is not maintained
     732$ b. their cardinality can not be computed using the okneltr routine
     733$    (multi-valued maps might have different maxindx and trivial (null)
     734$    range sets)
     735$ we also must take into account the "mixed case" of comparing a
     736$ single-valued map with a multi-valued map.  rather than duplicating
     737$ a fair amount of code here to handle all odd combinations,  we sepa-
     738$ rate single- and multi-valued cases:  if both maps are single-valued,
     739$ we update their nelt and compare their tuples;  otherwise we use the
     740$ general based-map case.
     741$
     742      if (is_mmap(st1)) go to based_map;
     743      if (is_mmap(st2)) go to based_map;
     744
     745      $ build specifiers for the embedded tuples
     746      st1 = st1 + hl_rmap;   st2 = st2 + hl_rmap;
     747
     748      $ to actually compute the correct specifier types here
     749      $ is somewhat of an overkill, since the type_ fields of
     750      $ these specifiers should never be used.
     751      $ (better careful now than sorry later...)
     752      if htype(st1) = h_tuple then
     753          t1 = t_tuple;
     754      else
     755          t1 = t_stuple;
     756      end if;
     757
     758      if htype(st2) = h_tuple then
     759          t2 = t_tuple;
     760      else
     761          t2 = t_stuple;
     762      end if;
     763
     764      build_spec(a1, t1, st1);   build_spec(a2, t2, st2);
     765
     766      $ compute the cardinality of the embedded tuples
     767      if (^ is_neltok(st1)) call okneltr(a1);
     768      if (^ is_neltok(st2)) call okneltr(a2);
     769      if (nelt(st1) ^= nelt(st2)) go to fail;
     770
     771      go to case(eq_tup);
     772
     773
     774
     775
     776
     777/mc(m_lmap, m_lmap)/   $ local maps on same base
     778
     779$ this case treats only local typed maps. for all other local
     780$ maps, we use the general based map case
     781
     782      if (htype(st1) ^= h_lmap ! htype(st2) ^= h_lmap)
     783          go to based_map;
     784
     785$ loop through the base, comparing images
     786
     787      off1 = ls_word(st1);
     788      off2 = ls_word(st2);
     789
     790      next_loop(e1, st1);
     791
     792          $ get images of e1
     793          a1 = heap(e1+off1);
     794          a2 = heap(e1+off2);
     795
     796          $ compare elements
     797          if is_multi_ a1 ^= is_multi_ a2 then $ standardize images
     798              l_call(std);   if (^ equal) go to fail;
     799          end if;
     800
     801          if (eq(a1, a2)) cont_next;
     802          if (ne(a1, a2)) go to fail;
     803
     804          elmt1 = e1;         $ save pointer across recursion
     805          r_call;
     806          e1 = elmt1;         $ restore pointer
     807
     808          if (^ equal) go to fail;
     809
     810      end_next;
     811
     812      go to pass;
     813
     814
     815/based_map/      $ all odd combinations of based maps
     816
     817/mc(m_rmap, m_lmap)/
     818
     819/mc(m_lmap, m_rmap)/
     820$ loop over base comparing functional value
     821
     822
     823      set1 = st1;   set2 = st2;   $ save in recursive variables
     824
     825      next_loop(e1, set1);
     826
     827          a1 = fval(set1, e1, no);
     828          a2 = fval(set2, e1, no);
     829
     830          if is_multi_ a1 ^= is_multi_ a2 then $ standardize images
     831              l_call(std);   if (^ equal) go to fail;
     832          end if;
     833
     834          if (eq(a1, a2)) cont_next;
     835          if (ne(a1, a2)) go to fail;
     836
     837          elmt1 = e1;         $ save pointer across recursion
     838          r_call;
     839          e1 = elmt1;         $ restore pointer
     840
     841          if (^ equal) go to fail;
     842
     843      end_next;
     844
     845      go to pass;
     846
     847
     848/mc(m_rmap, m_umap)/           $ based map(_b) * = unbased map(_b) *
     849
     850/mc(m_lmap, m_umap)/
     851
     852      swap(st1, st2)          $ swap arguments, go to next case
     853
     854
     855/mc(m_umap, m_lmap)/          $ sparse map(_b) * = local map(_b) *
     856
     857/mc(m_umap, m_rmap)/          $ sparse map(_b) * = remote map(_b) *
     858
     859$ iterate over the domain of the unbased map, getting pointers
     860$ into the base, then compare images.
     861
     862      set1 = st1;   set2 = st2;   $ save in recursive variables
     863
     864      next_loop(e1, set1);
     865
     866          $ get images
     867          a1 = ebimag(e1);
     868          a2 = fval(set2, value_ ebspec(e1), no);
     869
     870          $ standardize images
     871          if is_multi_ a1 ^= is_multi_ a2 then
     872              l_call(std);   if (^ equal) go to fail;
     873          end if;
     874
     875          if (eq(a1, a2)) cont_next;
     876          if (ne(a1, a2)) go to fail;
     877
     878          elmt1 = e1;         $ save across recursion
     879          r_call;
     880          e1 = elmt1;         $ restore pointer
     881
     882          if (^ equal) go to fail;
     883
     884      end_next;
     885
     886      go to pass;
     887
     888
     889/set_map/                     $ mixed set-map case
     890
     891      if (^ is_neltok(st1)) call okneltr(a1);
     892      if (^ is_neltok(st2)) call okneltr(a2);
     893      if (nelt(st1) ^= nelt(st2)) go to fail;
     894$
     895$ we handle the mixed set map case by iterating over the map and
     896$ testing its elements for membership in the set.  map iteration
     897$ is very slow, but it avoids testing map membership, which would
     898$ require great duplication of code.
     899$
     900$ when we iterate over the map, we must supply three arguments to
     901$ the next routine:
     902$
     903$ e1:     the previous element in standard format
     904$ iter:   the previous element in iterator format
     905$ savea1: the specifier for the set.
     906$
     907$ since 'e1' and 'iter' are local variables which are reset by the
     908$ next routine, we must pass them through temporaries.  note that
     909$ the third argument for the inext routine is a rw parameter as
     910$ well.
     911
     912$ make set2 the set.
     913
     914      if is_map(st2) then
     915          swap(a1, a2);   swap(st1, st2);
     916      end if;
     917$
     918$ iterate over the map, which at this point is 'a1'/'set1'
     919$
     920      call inext(e1, temp, a1);
     921      iter = temp;
     922      map  = a1;
     923
     924      while 1;
     925
     926          $ advance in the map
     927          temp = iter;
     928          call nexts(e1, temp, map);
     929          if (is_om_ temp) quit while 1;
     930          iter = temp;
     931
     932          init_probe(e1, st2, hashc, head);
     933
     934          probe_loop(e2, head);   $ iterate over clash list
     935
     936              if is_based(st2) then   $ check subset membership
     937                  if (fval(st2, e2, no) = no) cont_probe;
     938              end if;
     939
     940              a1 = e1;   a2 = ebspec(e2);
     941          $
     942          $ the elements of the map must be pairs.  furthermore,
     943          $ the next routine returns new pairs.  therefore they
     944          $ cannot be trivially equal to pairs in the set.  we
     945          $ do an r_call without the usual preliminary tests.
     946          $
     947              elmt1 = e1;   elmt2 = e2;   set2 = st2;
     948              r_call;
     949              e1 = elmt1;   e2 = elmt2;   st2 = set2;
     950
     951              if (equal) cont while 1;
     952
     953          end_probe;
     954
     955          go to fail;         $ e1 not element of proper clash list
     956
     957      end while 1;
     958
     959      go to pass;
     960
     961
     962
     963
     964/std/       $ local routine to standardize images
     965
     966$ this routine is called when we are comparing two maps m1 and m2. we
     967$ have found some element x in the domain of both maps and have set
     968$ a1 = fval(m1, x) and a2 = fval(m2, x). one of these map images has
     969$ its is_multi bit on; the other has its is_multi bit off. the images
     970$ can only be equal if the image with is_multi on represents a
     971$ singleton set.
     972
     973$ we determine which image has is_multi on, and apply arb1 to it. arb1
     974$ will see if the image is a null or singleton set, and if so apply
     975$ arb to it. otherwise it will return its argument, with its is_multi
     976$ bit still set.
     977
     978$ equal has been set to yes before this routine is called. it is
     979$ reset to no if the images cannot be standardized.
     980
     981      if is_multi_ a1 then  $ a1 is multivalued.
     982          a1 = arb1(a1);
     983          if (is_multi_ a1) equal = no;  $ still multivalued.
     984
     985      else  $ a2 is multivalued
     986          a2 = arb1(a2);
     987          if (is_multi_ a2) equal = no;  $ still multivalued
     988      end if;
     989
     990      go to rlab(retpt) in 1 to zzya;  $ return
     991
     992
     993
     994
     995$ recursive return points.
     996
     997/fail/                        $ return false
     998
     999      equal = no;             go to exit;
    1000
    1001
    1002/pass/                        $ return true
    1003
    1004      equal = yes;            go to exit;
    1005
    1006
    1007/exit/                        $ actual return point
    1008
    1009      r_exit;                 $ pop recursion stack
    1010
    1011      if t ^= tstart then     $ return from recursive call.
    1012          go to rlab(retpt) in 1 to zzya;
    1013      else
    1014          return;
    1015      end if;
    1016
    1017
    1018$ drop local variables
    1019
    1020      macdrop8(retpt, p1, p2, plim, bpos, pbits, pkey, sameb)
    1021      macdrop8(dsize, dcntr, set1, head1, elmt1, off1, set2, head2)
    1022      macdrop4(elmt2, off2, size2, iter)
    1023      macdrop (map)
    1024
    1025      macdrop2(tc, sc)    $ drop case labels
    1026      macdrop(mc)
    1027
    1028
    1029      end fnct equal;
       1 .=member eqrs
       2      fnct eqrs(arg1, arg2);
       3
       4$ this routine is called from -equal- to compare remote
       5$ subsets on the same base. since it contains no test for hash
       6$ or nelt, it should be called only from -equal-.
       7
       8
       9      size eqrs(1);       $ boolean value returned
      10
      11      size arg1(hs),  $ specifiers for sets being compared
      12           arg2(hs);
      13
      14      size p1(ps),   $ pointers to the two sets
      15           p2(ps);
      16      size word1(ps);         $ word offset for shorter argument
      17      size word2(ps);         $ word offset for longer argument
      18      size len1(ps);          $ number of words in shorter bit string
      19      size len2(ps);          $ number of words in longer bit string
      20      size j(ps);             $ loop index
      21
      22
      23
      24      p1 = value_ arg1;
      25      p2 = value_ arg2;
      26
      27      len1 = rswords(p1);   len2 = rswords(p2);
      28
      29      if len1 > len2 then
      30          swap(len1, len2);
      31          word1 = p2 + hl_rset;   word2 = p1 + hl_rset;
      32      else
      33          word1 = p1 + hl_rset;   word2 = p2 + hl_rset;
      34      end if;
      35
      36      do j = 0 to len1-1;
      37          if heap(word1+j) ^= heap(word2+j) then
      38              eqrs = no;
      39              return;
      40          end if;
      41      end do;
      42
      43      do j = len1 to len2-1;
      44          if heap(word2+j) ^= 0 then
      45              eqrs = no;
      46              return;
      47          end if;
      48      end do;
      49
      50      eqrs = yes;
      51
      52
      53      end fnct eqrs;
       1 .=member eqls
       2      fnct eqls(arg1, arg2);
       3
       4$ this routine is called from -equal- to test local subset equality
       5$ since it does not test hashes or nelts, it should never be called
       6$ directly from the interpreter.
       7
       8
       9      size eqls(1);     $ boolean value returned
      10
      11      size arg1(hs),     $ specifiers for sets being compared
      12           arg2(hs);
      13
      14      size word1(ps),    $ word offsets of arguments
      15           word2(ps),
      16           bit1(ps),     $ bit offsets of arguments
      17           bit2(ps),
      18           e(ps);  $ pointer to current base element
      19
      20
      21$ get word and bit positions for the
      22$ two maps.
      23      word1 = ls_word(value_ arg1);
      24      bit1 = ls_bit(value_ arg1);
      25
      26      word2 = ls_word(value_ arg2);
      27      bit2 = ls_bit(value_ arg2);
      28
      29$ loop through bases, comparing images.
      30      next_loop(e, value_ arg1);
      31          if .f. bit1,1,heap(e+word1) ^= .f. bit2, 1, heap(e+word2) then
      32              eqls = no;
      33              return;
      34          end if;
      35      end_next;
      36
      37      eqls = yes;
      38
      39
      40      end fnct eqls;
       1 .=member eqlrs
       2      fnct eqlrs(arg1, arg2);
       3$
       4$ this routine evaluates the equality of a local and a remote
       5$ subset of a common base.
       6$
       7
       8$ this routine is called from -equal-. since it contains no tests
       9$ for hashes and nelts, it should never be called from the interpreter
      10$ its is only a seperate routine so that -equal- fits the little
      11$ compiler.
      12$
      13$ assert isset(arg1) & isset(arg2);
      14$ assert htype(value_ arg1) = h_lset;
      15$ assert htype(value_ arg2) = h_rset;
      16$ assert ft_elmt(hform(value_ arg1)) = ft_elmt(hform(value_ arg2));
      17$
      18      size eqlrs(1);          $ boolean value returned
      19
      20      size arg1(hs);          $ specifiers for two arguments
      21      size arg2(hs);
      22
      23      size set1(ps);          $ pointers to two sets
      24      size set2(ps);
      25      size e(ps);             $ pointer to current base element
      26      size eb(ps);            $ pointer to base element block
      27      size bit(ps);           $ ls_bit of local set
      28      size word(ps);          $ ls_word of local set
      29      size indx(ps);          $ ebindx of remote set
      30      size maxi(ps);          $ rs_maxi of remote set
      31
      32      size fval(hs);          $ function called
      33
      34
      35      set1 = value_ arg1;     $ get pointers to sets
      36      set2 = value_ arg2;
      37
      38      bit  = ls_bit(set1);    word = ls_word(set1);
      39      maxi = rs_maxi(set2);
      40
      41      next_loop(eb, set1);    $ (forall eb in base)
      42          indx = ebindx(eb);  if (indx > maxi) indx = 0;
      43
      44          if .f. bit, 1, heap(eb+word) ^= rsbit(set2, indx) then
      45              eqlrs = no;
      46              return;
      47          end if;
      48      end_next;
      49
      50      eqlrs = yes;
      51
      52
      53      end fnct eqlrs;
       1 .=member eqtup1
       2      fnct eqtup1(arg1, arg2);  $ equality test for packed tuples
       3
       4$ this routine is called from -equal-. since it contains no tests
       5$ for hashes and nelts, it should never be called from the interpreter
       6$ its is only a seperate routine so that -equal- fits the little
       7$ compiler.
       8
       9
      10      size eqtup1(1);   $ boolean value returned
      11
      12      size arg1(hs),   $ specifiers for tuples being compared
      13           arg2(hs);
      14
      15      size a1(hs),   $ specifiers for components
      16           a2(hs);
      17
      18      size tup1(ps),    $ pointers to tuples
      19           tup2(ps),
      20           pbits1(ps),    $ their ptbits fields
      21           pbits2(ps),
      22           ptkey1(hs),        $ their key fields
      23           ptkey2(hs);
      24
      25      size p1(ps),   $ pointers to words for current components
      26           p2(ps),
      27           bpos1(ps),  $ first bit positions of current components
      28           bpos2(ps);
      29
      30      size j(ps),    $ loop index
      31           val(hs);   $ packed value of current component
      32
      33
      34      tup1 = value_ arg1;  $ point to tuples
      35      tup2 = value_ arg2;
      36
      37$ see if both tuples have the same ptkey and ptbits.  if so, we
      38$ can compare them using full word comparisons.
      39
      40      if ptkey(tup1) = ptkey(tup2) & ptbits(tup1) = ptbits(tup2) then
      41                      $ do full word test
      42          eqtup1 = yes;
      43
      44          do j = 1 to packwords(tup1);
      45              if packword(tup1, j) ^= packword(tup2, j) then
      46                  eqtup1 = no;
      47                  quit;
      48              end if;
      49          end do;
      50
      51          return;
      52
      53      end if;
      54
      55$ otherwise do element by element test. start by getting packing info.
      56
      57
      58$ get packing information
      59
      60      pbits1 = ptbits(tup1);      $ bits/entry
      61      ptkey1 = ptkey(tup1);
      62
      63      pbits2 = ptbits(tup2);
      64      ptkey2 = ptkey(tup2);
      65
      66
      67$ initialize p1 and p2 to point to the word containing the zero-th
      68$ component and bpos1 and bpos2 to the bit origin for this component
      69      p1 = tup1 + hl_ptuple;
      70      bpos1 = 1;
      71
      72      p2 = tup2 + hl_ptuple;
      73      bpos2 = 1;
      74
      75      do j = 1 to nelt(tup1);
      76
      77          bpos1 = bpos1+pbits1;
      78          if bpos1 > bpos_max then
      79              p1 = p1+1;
      80              bpos1 = 1;
      81          end if;
      82
      83          val = .f. bpos1, pbits1, heap(p1);   $ packed value_
      84
      85          if val < pack_max then
      86              a1 = tcomp(ptkey1, val);
      87          else
      88              a1 = 0;    $ build short integer
      89              value_ a1 = val;
      90          end if;
      91
      92
      93          bpos2 = bpos2+pbits2;    $ repeat for second tuple
      94          if bpos2 > bpos_max then
      95              p2 = p2+1;    $ start new word
      96              bpos2 = 1;
      97          end if;
      98
      99          val = .f. bpos2, pbits2, heap(p2);
     100
     101          if val < pack_max then
     102              a2 = tcomp(ptkey2, val);
     103          else
     104              a2 = 0;
     105              value_ a2 = val;
     106          end if;
     107
     108$ compare a1 and a2
     109
     110          if ^ eq(a1, a2) then
     111              eqtup1 = no;
     112              return;
     113          end if;
     114
     115      end do;
     116
     117      eqtup1 = yes;
     118
     119      return;
     120
     121      end fnct eqtup1;
       1 .=member eqtup2
       2      fnct eqtup2(arg1, arg2);  $ equality test for real tuple - tuple
       3
       4$ this routine is called from -equal-. since it contains no tests
       5$ for hashes and nelts, it should never be called from the interpreter
       6$ its is only a seperate routine so that -equal- fits the little
       7$ compiler.
       8
       9
      10      size eqtup2(1);    $ boolean values returned
      11
      12      size arg1(hs),  $ specifiers for tuples being compared
      13           arg2(hs);
      14
      15      size a1(hs),  $ specifiers for components
      16           a2(hs);
      17
      18      size p1(ps),      $ pointers to tuples
      19           p2(ps);
      20
      21      size j(ps);   $ loop index
      22
      23
      24      p1 = value_ arg1;  $ get pointers to tuples
      25      p2 = value_ arg2;
      26
      27      do j = 1 to nelt(p1);
      28
      29          a1 = tcomp(p1, j);
      30          a2 = tcomp(p2, j);
      31
      32$ see if both om.
      33          if (a1 = om_real & is_om_ a2) cont;
      34
      35          if a1 ^= rval(value_ a2) then  $ values unequal
      36              eqtup2 = no;
      37              return;
      38          end if;
      39
      40      end do;
      41
      42      eqtup2 = yes;
      43
      44
      45      end fnct eqtup2;
       1 .=member eqtup3
       2      fnct eqtup3(arg1, arg2);  $ equality test for integer tuple - tupl
       3
       4$ this routine is called from -equal-. since it contains no tests
       5$ for hashes and nelts, it should never be called from the interpreter
       6$ its is only a seperate routine so that -equal- fits the little
       7$ compiler.
       8
       9
      10      size eqtup3(1);   $ boolean value returned
      11
      12      size arg1(hs),    $ specifiers for tuples being compared
      13           arg2(hs);
      14
      15      size p1(ps),      $ pointers to tuples
      16           p2(ps);     $ pointers to tuples
      17
      18      size a1(hs),   $ specifiers for components
      19           a2(hs);
      20
      21      size p(ps),   $ pointer to long integer value
      22           j(ps);    $ loop index
      23
      24
      25      p1 = value_ arg1;  $ get pointers to tuples
      26      p2 = value_ arg2;
      27
      28
      29$ note - we assume that the maximum untyped
      30$ integer can be stored as a 1 word long int.
      31
      32      do j = 1 to nelt(p1);
      33
      34          a1 = tcomp(p1, j);
      35          a2 = tcomp(p2, j);
      36
      37          if is_om_ a1 then  $ a2 must be om_int.
      38              if (a2 ^= om_int) go to fail;
      39
      40          elseif type_ a1 = t_int then
      41              if (ivalue_ a1 ^= a2) go to fail;
      42
      43          elseif type_ a1 = t_lint then  $ long int vs. untyped
      44              p = value_ a1;
      45              if (li_nwords(p) ^= 2 ! liword(p, 1) ^= a2) go to fail;
      46
      47          else               $ a1 some other type_
      48              go to fail;
      49          end if;
      50
      51      end do;
      52
      53
      54/pass/     $ return true
      55      eqtup3 = yes;
      56      return;
      57
      58
      59/fail/     $ return false
      60      eqtup3 = no;
      61      return;
      62
      63      end fnct eqtup3;
       1 .=member eqtup4
mjsa  29      fnct eqtup4(a1, a2);
       2
       3$ this routine is called from -equal-. since it contains no tests
       4$ for hashes and nelts, it should never be called from the interpreter
       5$ its is only a seperate routine so that -equal- fits the little
       6$ compiler.
       7
       8
       9      size eqtup4(1);    $ boolean value returned
      10
      11      size a1(hs),      $ specifiers for tuples
      12           a2(hs);
      13
      14      size p1(ps),    $ pointers to tuples
      15           p2(ps);
      16
      17      size j(ps);   $ loop index
      18
      19
      20      p1 = value_ a1;  $ get pointers to tuples
      21      p2 = value_ a2;
      22
      23      do j = 1 to nelt(p1);
      24
      25          if tcomp(p1, j) ^= tcomp(p2, j) then
      26              eqtup4 = no;
      27              return;
      28          end if;
      29
      30      end do;
      31
      32      eqtup4 = yes;
      33
      34
      35      end fnct eqtup4;
       1 .=member eqprim
       2      fnct eqprim(arg1, arg2);
       3
       4$ this routine tests the equality of primitive types
       5
       6
       7      size eqprim(1);         $ boolean value returned
       8
       9      size arg1(hs);          $ specifiers for inputs
      10      size arg2(hs);
      11
      12      size ss1(ssz);          $ string specifiers for inputs
      13      size ss2(ssz);
      14      size len(ps);           $ length of strings
      15      size cc(ps);            $ condition code, result of string comp
      16
      17      real real1, real2;      $ real temporaries
      18
mjsa  30      size equalli(1);
      20      size eqstr(1);
      21
      22
stra 104      if (otype_ arg1 ^= otype_ arg2) go to mixed;
      24
stra 105      go to case(otype_ arg1) in t_lint to t_real;
      26
      27
      28/case(t_lint)/                $ long integers
      29
mjsa  31      eqprim = equalli(arg1, arg2);
      31
      32      return;
      33
      34
      35/case(t_istring)/             $ indirect character strings
      36
      37      ss1 = value_ arg1;   ss2 = value_ arg2;
      38
      39      len = ss_len(ss1);
      40
      41      if len ^= ss_len(ss2) then
      42          eqprim = no;
      43          return;
      44      end if;
      45
      46      clc(cc, ss1, ss2, len);
      47
      48      eqprim = (cc = 0);
      49
      50      return;
      51
      52
      53/case(t_real)/                $ reals
      54
      55      real1 = rval(value_ arg1);
      56      real2 = rval(value_ arg2);
      57      eqprim = (real1 = real2);
      58
      59      return;
      60
      61
      62/mixed/     $ mixed input types
      63
      64$ the only mixed case we allow is long vs. short string
      65
stra 106      if otype_ arg1 = t_string & otype_ arg2 = t_istring then
      67          eqprim = eqstr(arg2, arg1);
      68
stra 107      elseif otype_ arg1 = t_istring & otype_ arg2 = t_string then
      70          eqprim = eqstr(arg1, arg2);
      71
      72      else
      73          eqprim = no;
      74      end if;
      75
      76      return;
      77
      78
      79      end fnct eqprim;
       1 .=member eqstr
       2      fnct eqstr(long, short);
       3
       4$ this routine compares a long string for equality with
       5$ a short one.
       6
       7
       8      size long(hs),   $ specifier for long string
       9           short(hs);  $ specifier for short string
      10
      11      size eqstr(1);   $ boolean value returned
      12
      13      size len(ps),   $ length of strings
      14           ss(ssz),   $ specifier for long string
      15           j(ps);     $ loop index
      16
      17
      18      eqstr = no;  $ assume unequal
      19
      20      ss = value_ long;
      21      len = ss_len(ss);
      22
      23      if (len ^= sc_nchars_ short) return;
      24
      25      do j = 1 to len;
stra 108          if (icchar(ss, j) ^= scchar(short, j)) return;
      27      end do;
      28
      29      eqstr = yes;   $ strings equal
      30
      31
      32      end fnct eqstr;
       1 .=member add
       2      fnct add(a1, a2, cpy);
       3
       4$ this is the general setl addition function. it performs short addition
       5
       6$ 'cpy' is a flag indicating what copying actions must be
       7$ performed on a1.
       8$ in line and calls seperate lower level routines for each long type.
       9
      10
      11      size a1(hs),            $ specifiers for arguments
      12           a2(hs),
      13           cpy(ps);           $ copy flag
      14
      15      size add(hs);           $ specifier returned
      16
      17      size arg1(hs),          $ local copies of arguments
      18           arg2(hs);
      19
      20      size val(hs);           $ temporary numeric value
      21
      22      real real1,             $ real temporaries
      23           real2;
      24
      25      size addli(hs),         $ functions called
      26           addstr(hs),
      27           addtup(hs),
      28           union(hs),
      29           sfloat(hs),
      30           copy1(hs),
      31           convert(hs),
      32           err_val(hs);
      33
      34
      35      arg1 = a1;   deref(arg1);
      36      arg2 = a2;   deref(arg2);
      37
      38
      39$ do any necessary copying
      40
      41      go to c(cpy) in copy_min to copy_max;
      42
      43
      44/c(copy_yes)/     $ copy arg1
      45
      46      arg1 = copy1(arg1);
      47
      48      go to esac;
      49
      50
      51/c(copy_test)/                $ copy arg1 if -
      52                              $  -  it is shared.
      53                              $  -  it is a long character string.
      54
      55      if (is_shared_ arg1 ! otype_ arg1 = t_istring)
      56          arg1 = copy1(arg1);
      57
      58      go to esac;
      59
      60
      61/c(copy_no)/       $ no copy necessary
      62
      63      go to esac;
      64
      65
      66/esac/                        $ branch on omega-type field of -arg1-
      67
      68      go to case(otype_ arg1) in t_min to t_max;
      69
      70
      71/case(t_int)/          $ short int
      72
      73$ this case will always be caught by a preliminary test in the
      74$ interpreter, and is here only for completeness
      75
      76      val = otvalue_ arg1 + otvalue_ arg2;
      77      if (val > maxsi) go to case(t_lint);
      78
      79      add         = 0;        $ assert t_int = 0, simplify build_spec
      80      ivalue_ add = val;
      81
      82      return;
      83
      84
stra 109/case(t_string)/              $ short character string
stra 110
stra 111      if ^ (otype_ arg2 = t_string ! otype_ arg2 = t_istring) then
stra 112          go to error2;
stra 113      end if;
stra 114
stra 115      add = addstr(arg1, arg2);
stra 116
stra 117      return;
stra 118
      86
stra 119/case(t_atom)/                $ error types
      88
      89/case(t_proc)/
      90
      91/case(t_lab)/
      92
      93/case(t_latom)/         $ error type - long atom
      94
      95/case(t_elmt)/      $ element - we should never reach here
      96
      97      go to error1;
      98
      99
     100/case(t_lint)/                $ long integers
     101
     102      if (otype_ arg2 ^= t_int & otype_ arg2 ^= t_lint) go to error2;
     103
     104      add = addli(arg1, arg2);
     105
     106      return;
     107
     108
     109/case(t_istring)/             $ long character strings
     110
stra 120      if ^ (otype_ arg2 = t_string ! otype_ arg2 = t_istring) then
stra 121          go to error2;
stra 122      end if;
     112
     113      $ always copy strings before destructive use, regardless
     114      $ of the setting of the copy flag.
     115      if cpy = copy_no then arg1 = copy1(arg1); end if;
     116
     117      add = addstr(arg1, arg2);
     118
     119      return;
     120
     121
     122/case(t_real)/                $ reals
     123
     124      if (otype_ arg2 ^= t_real) go to error2;
     125
     126      real1 = rval(value_ arg1);
     127      real2 = rval(value_ arg2);
     128
     129      val = real1 + real2;
     130      put_realval(val, add);
     131
     132      return;
     133
     134
     135/case(t_tuple)/               $ tuples
     136
     137/case(t_stuple)/
     138
     139      if (otype_ arg2 ^= t_tuple & otype_ arg2 ^= t_stuple)
     140          go to error2;
     141
     142      if ft_type(hform(value_ arg1)) = f_mtuple !
     143              hform(value_ arg1) ^= hform(value_ arg2) then
     144          arg1 = convert(arg1, f_tuple);
     145          arg2 = convert(arg2, f_tuple);
     146      end if;
     147
     148      add = addtup(arg1, arg2);
     149
     150      return;
     151
     152
     153/case(t_set)/                 $ sets and maps
     154
     155/case(t_map)/
     156
     157      if (^ isset(otype_ arg2)) go to error2;
     158
     159      add = union(arg1, arg2, no);
     160
     161      return;
     162
     163
     164case_om                       $ omega ceses - treat as errors
     165
     166/error1/                      $ invalid type for left operand
     167
     168      call err_type(2);
     169      add = err_val(f_gen);
     170
     171      return;
     172
     173
     174/error2/                      $ incompatible argument types
     175
     176      call err_type(3);
     177      add = err_val(f_gen);
     178
     179      return;
     180
     181
     182      end fnct add;
       1 .=member addstr
       2      fnct addstr(arg1, arg2);
       3
stra 123$ this routine concatenates two character strings.  both operands may be
stra 124$ either a short or a long character string;  the result will always be
stra 125$ a long character string.  the first operand is used destructively.
       7
       8      size arg1(hs);          $ specifier for first string
       9      size arg2(hs);          $ specifier for second string
      10
      11      size addstr(hs);        $ specifier returned
      12
      13      size ss1(ssz);          $ string specifiers
      14      size ss2(ssz);
      16      size len1(ps);          $ lengths of strings
      17      size len2(ps);
      18      size tot(ps);           $ total length
      19      size j(ps);             $ loop index
stra 126
stra 127      size nulllc(ssz);       $ allocates null string
      20
      21
stra 128      if otype_ arg1 = t_string then
stra 129          len1 = sc_nchars_ arg1;  $ get length of first operand
stra 130          ss1 = nulllc(len1);  $ convert short string
stra 131          ss_len(ss1) = len1;
stra 132          if len1 then  icchar(ss1, 1) = scchar(arg1, 1);  end if;
stra 133      elseif otype_ arg1 = t_istring then
stra 134          ss1 = value_ arg1;
stra 135          len1 = ss_len(ss1);  $ get length of first operand
stra 136      else
stra 137          addstr = err_val(f_string);
stra 138          return;
stra 139      end if;
stra 140
stra 141      if otype_ arg2 = t_string then
stra 142          len2 = sc_nchars_ arg2;  $ get length of second operand
stra 143
stra 144          if len2 then
stra 145              tot = len1 + len2;  $ compute length of result
stra 146
stra 147              call explc(ss1, tot);  $ expand result string
stra 148              ss_len(ss1) = tot;  $ set length of result
stra 149
stra 150              icchar(ss1, tot) = scchar(arg2, 1);
stra 151          end if;
stra 152
stra 153      elseif otype_ arg2 = t_istring then
stra 154          ss2 = value_ arg2;  $ get string pointer to second operand
stra 155          len2 = ss_len(ss2);  $ get length of second operand
stra 156
stra 157          tot = len1 + len2;  $ compute length of result
stra 158
stra 159          call explc(ss1, tot);  $ expand result string
stra 160          ss_len(ss1) = tot;  $ set length of result
stra 161
stra 162          ss_ofs(ss1) = ss_ofs(ss1) + len1;  $ point to end of string
stra 163          mvc(ss1, ss2, len2);  $ copy the second string
stra 164          ss_ofs(ss1) = ss_ofs(ss1) - len1;  $ reset to point to start
stra 165
stra 166      else
stra 167          addstr = err_val(f_string);
stra 168          return;
stra 169      end if;
stra 170
stra 171      build_spec(addstr, t_istring, ss1);  $ build result specifier
      41
      42
      43      end fnct addstr;
       1 .=member addtup
       2      fnct addtup(a1, a2);
       3
       4$ this routine 'adds' or concatenates two tuples. the first
       5$ argument is used destructively.
       6
       7
       8      size a1(hs),   $ specifier for first tuple
       9           a2(hs);   $ specifier for second tuple
      10
      11      size addtup(hs);  $ specifier returned
      12
      13      size p1(ps),  $ pointers to tuples
      14           p2(ps);
      15
      16      size len1(ps), $ length of a1
      17           len2(ps), $ length of a2
      18           tot(ps);  $ total length
      19
      20      size j(ps);  $ loop index
      21
      22
      23      p1 = value_ a1;  $ get pointers to arguments
      24      p2 = value_ a2;
      25
      26      len1 = nelt(p1);  $ get lengths
      27      len2 = nelt(p2);
      28
      29      tot = len1 + len2;
      30
      31      addtup = a1;  $ we will use a1 destructively.
      32
      33      if tot > maxindx(p1) then $ must expand result
      34          call exptup(addtup, tot);
      35          p1 = value_ addtup;
      36      end if;
      37
      38      if htype(p1) = h_ptuple then
      39          do j = 1 to len2;
      40              pcomp(p1, len1+j) = pcomp(p2, j);
      41          end do;
      42
      43      else
      44          do j = 1 to len2;
      45              tcomp(p1, len1+j) = tcomp(p2, j);
      46          end do;
      47      end if;
      48
      49      nelt(p1) = tot;         $ set nelt of result
      50
      51
      52      end fnct addtup;
       1 .=member diff
       2      fnct diff(a1, a2, cpy);
       3
       4$ this is the general setl subtraction function. it performs short
       5$ subtraction in line and calls seperate lower level routines for eac
       6$ long type
       7
       8$ 'cpy' is a flag indicating what copying actions must be
       9$ performed on a1.
      10
      11
      12      size diff(hs);   $ specifier returned
      13
      14      size a1(hs),   $ specifiers for arguments
      15           a2(ps),
      16           cpy(ps);   $ copy flag
      17
      18      size arg1(hs),     $ local copies of arguments
      19           arg2(hs);
      20
      21      size val(hs),  $ differencr of two ints
      22           len(ps),  $ length of bit strings
      23           p(ps);    $ pointer to real value
      24
      25      real real1,    $ temporaries for real values
      26           real2;
      27
      28      size diffli(hs),  $ functions called
      29           copy1(hs),
      30           setdiff(hs);
      31
      32
      33      arg1 = a1;  $ copy specifiers for arguments
      34      arg2 = a2;
      35
      36      deref(arg1);  $ dereference if necessary
      37      deref(arg2);
      38
      39
      40$ do any necessary copying
      41
      42      go to c(cpy) in copy_min to copy_max;
      43
      44/c(copy_yes)/     $ copy arg1
      45
      46      arg1 = copy1(arg1);
      47      go to esac;
      48
      49
      50/c(copy_test)/     $ copy arg1 if shared
      51
      52      maycopy(arg1);
      53      go to esac;
      54
      55
      56/c(copy_no)/       $ no copy necessary
      57
      58
      59      go to esac;
      60
      61/esac/
      62
      63
      64      diff = 0;  $ initialize, clearing eblink, etc.
      65
      66                 $ branch on type of first arg
      67
      68      go to case(otype_ arg1) in t_min to t_max;
      69
      70
      71/case(t_int)/          $ short int
      72
      73$ this case will be caught by the interpreter. it is here only for
      74$ completeness. note that the underflow test also catches cases where
      75$ the second argument is not a short int.
      76
      77      val = otvalue_ arg1 - otvalue_ arg2;
      78      if (val < 0) go to case(t_lint);
      79
      80      otvalue_ diff = val;
      81
      82      return;
      83
      84
      85/case(t_string)/        $ error types
      86
      87/case(t_atom)/
      88
      89/case(t_proc)/
      90
      91/case(t_lab)/
      92
      93/case(t_latom)/         $ error type - long atom
      94
      95/case(t_elmt)/    $ element - we should never reach here
      96
      97      go to error1;
      98
      99
     100/case(t_lint)/         $ long integers
     101
     102      if (otype_ arg2 ^= t_int & otype_ arg2 ^= t_lint) go to error2;
     103
     104      diff = diffli(arg1, arg2);
     105
     106      return;
     107
     108
     109/case(t_istring)/       $ error type - long chars
     110
     111      go to error1;
     112
     113
     114/case(t_real)/         $ reals
     115
     116      if (otype_ arg2 ^= t_real) go to error2;
     117
     118      real1 = rval(value_ arg1);
     119      real2 = rval(value_ arg2);
     120
     121      get_real(p);
     122      build_spec(diff, t_real, p);  $ build specifier
     123
     124      rval(p) = real1 - real2;  $ do real diff
     125
     126      return;
     127
     128
     129/case(t_tuple)/         $ error types - tuples
     130
     131/case(t_stuple)/
     132
     133      go to error1;
     134
     135
     136/case(t_set)/       $ sets and maps
     137
     138/case(t_map)/
     139
     140      if (^ isset(otype_ arg2)) go to error2;
     141
     142      diff = setdiff(arg1, arg2);
     143
     144      return;
     145
     146
     147case_om;     $ om types - treat as errors
     148
     149/error1/            $ bad type for first argument
     150
     151      call err_type(4);
     152      diff = err_val(f_gen);
     153      return;
     154
     155
     156/error2/            $ incompatible argument types
     157
     158      call err_type(5);
     159      diff = err_val(f_gen);
     160      return;
     161
     162
     163      end fnct diff;
       1 .=member div
       2      fnct div(a1, a2);
       3
       4$ this is the general setl division function. it performs short division
       5$ in line and calls seperate lower level routines for each long type.
       6
       7
       8      size div(hs);  $ specifier returned
       9
      10      size a1(hs),   $ specifiers for arguments
      11           a2(hs);
      12
      13      size arg1(hs),     $ local copies of argemeunt
      14           arg2(hs);
      15
      16      size val(hs);           $ quotient of two integers
      17
      18      size divli(hs);   $ functions called
      19
      20
      21      arg1 = a1;   deref(arg1);
      22      arg2 = a2;   deref(arg2);
      23
      24      go to case(otype_ arg1) in t_min to t_max;
      25
      26
      27/case(t_int)/          $ short int
      28
      29$ this case will generally be caught in the interpreter, and is here
      30$ only for completeness.
      31
      32      if (otype_ arg2 ^= t_int) go to case(t_lint);
      33      if (otvalue_ arg2 = 0) go to error3;
      34
      35      val = otvalue_ arg1 / otvalue_ arg2;
      36
      37      div         = 0;        $ assert t_int = 0, simplify build_spec
      38      otvalue_ div = val;
      39
      40      return;
      41
      42
      43/case(t_string)/        $ error types
      44
      45/case(t_atom)/
      46
      47/case(t_proc)/
      48
      49/case(t_lab)/
      50
      51/case(t_latom)/
      52
      53/case(t_elmt)/  $ we should never reach here
      54
      55      go to error1;
      56
      57
      58/case(t_lint)/         $ long integers
      59
      60      if (otype_ arg2 ^= t_int & otype_ arg2 ^= t_lint) go to error2;
      61      if (otvalue_ arg2 = 0) go to error3;
      62
      63      div = divli(arg1, arg2);
      64
      65      return;
      66
      67
      68/case(t_istring)/       $ error type - long chars
      69
      70/case(t_real)/         $ reals
      71
      72/case(t_tuple)/
      73
      74/case(t_stuple)/
      75
      76/case(t_set)/
      77
      78/case(t_map)/
      79
      80      go to error1;
      81
      82
      83case_om;        $ om types - treat as errors
      84
      85/error1/            $ bad type for first argument
      86
      87      call err_type(6);
      88      div = err_val(f_gen);
      89      return;
      90
      91
      92/error2/            $ incompatible argument types
      93
      94      call err_type(7);
      95      div = err_val(f_gen);
      96      return;
      97
      98
      99/error3/                      $ division by zero
     100
     101      call err_misc(01);
     102      div = err_val(f_gen);
     103      return;
     104
     105
     106      end fnct div;
       1 .=member slash
       2      fnct slash(a1, a2);
       3
       4$ this routine computes arg1 / arg2. it is similar to div except
       5$ that it converts integers to reals before dividing them.
       6
       7
       8      size slash(hs);  $ specifier returned
       9
      10      size a1(hs),   $ specifiers for arguments
      11           a2(hs);
      12
      13      size arg1(hs),     $ local copies of argemeunt
      14           arg2(hs);
      15
      16      size val(hs),  $ quotient of two ints
      17           p(ps);    $ pointer to real value
      18
      19      real real1,   $ temporaries for real values
      20           real2;
      21
      22      size sfloat(hs);  $ setl float function
      23
      24
      25      arg1 = a1;   deref(arg1);
      26      arg2 = a2;   deref(arg2);
      27
      28      go to case(otype_ arg1) in t_min to t_max;
      29
      30
      31/case(t_int)/          $ short int
      32
      33$ this case will generally be caught in the interpreter, and is here
      34$ only for completeness.
      35
      36      if (otype_ arg2 ^= t_int) go to case(t_lint);
      37      arg1 = sfloat(arg1);
      38      arg2 = sfloat(arg2);
      39
      40      go to case(t_real);
      41
      42
      43/case(t_string)/        $ error types
      44
      45/case(t_atom)/
      46
      47/case(t_proc)/
      48
      49/case(t_lab)/
      50
      51/case(t_latom)/
      52
      53/case(t_elmt)/  $ we should never reach here
      54
      55      go to error1;
      56
      57
      58/case(t_lint)/         $ long integers
      59
      60      if (otype_ arg2 ^= t_int & otype_ arg2 ^= t_lint) go to error2;
      61
      62      arg1 = sfloat(arg1);
      63      arg2 = sfloat(arg2);
      64
      65      go to case(t_real);
      66
      67
      68/case(t_istring)/       $ error type - long chars
      69
      70      go to error1;
      71
      72
      73/case(t_real)/         $ reals
      74
      75      if (otype_ arg2 ^= t_real) go to error2;
      76
      77      real1 = rval(value_ arg1);
      78      real2 = rval(value_ arg2);
      79
      80      if (real2 = 0.0) go to error3;
      81
      82      val = real1 / real2;
      83      put_realval(val, slash);
      84
      85      return;
      86
      87
      88/case(t_tuple)/
      89
      90/case(t_stuple)/
      91
      92/case(t_set)/
      93
      94/case(t_map)/
      95
      96      go to error1;
      97
      98
      99case_om;        $ om types - treat as errors
     100
     101/error1/            $ bad type for first argument
     102
     103      call err_type(8);
     104      slash = err_val(f_gen);
     105      return;
     106
     107
     108/error2/            $ incompatible argument types
     109
     110      call err_type(9);
     111      slash = err_val(f_gen);
     112      return;
     113
     114
     115/error3/                      $ division by zero
     116
     117      call err_misc(01);
     118      slash = err_val(f_gen);
     119      return;
     120
     121
     122      end fnct slash;
       1 .=member smod
       2      fnct smod(a1, a2);
       3
       4$ this is the general setl modulo function. it performs short
       5$ modulo in line and calls seperate lower level routines for eac
       6$ long type
       7
       8
       9      size smod(hs);    $ specifier returned
      10
      11      size a1(hs),   $ specifiers for arguments
      12           a2(hs);
      13
      14      size arg1(hs),     $ local copies of argemeunt
      15           arg2(hs);
      16
      17      size len(ps);   $ length of bit string
      18
      19
      20      size modli(hs),   $ functions called
      21           modlb(hs),
      22           setmod(hs);
      23
      24
      25      arg1 = a1;  $ copy specifiers for arguments
      26      arg2 = a2;
      27
      28      deref(arg1);  $ dereference if necessary
      29      deref(arg2);
      30
      31      smod = 0;  $ clear share bit, etc.
      32
      33                 $ branch on type of first arg
      34
      35      go to case(otype_ arg1) in t_min to t_max;
      36
      37
      38/case(t_int)/          $ short int
      39
      40$ this case is generally caught in line.
      41      if (otype_ arg2 ^= t_int) go to case(t_lint);
      42
      43      otvalue_ smod = mod(otvalue_ arg1, otvalue_ arg2);
      44
      45      return;
      46
      47
      48/case(t_string)/        $ error types
      49
      50/case(t_atom)/
      51
      52/case(t_proc)/
      53
      54/case(t_lab)/
      55
      56/case(t_latom)/         $ error type - long atom
      57
      58/case(t_elmt)/        $ we should never reach here
      59
      60      go to error1;
      61
      62
      63/case(t_lint)/         $ long integers
      64
      65      if (otype_ arg2 ^= t_int & otype_ arg2 ^= t_lint) go to error2;
      66
      67      smod = modli(arg1, arg2);
      68
      69      return;
      70
      71
      72/case(t_istring)/       $ error type - long chars
      73
      74/case(t_real)/         $ error - reals
      75
      76/case(t_tuple)/         $ error types - tuples
      77
      78/case(t_stuple)/
      79
      80      go to error1;
      81
      82
      83/case(t_set)/      $ sets and maps
      84
      85/case(t_map)/
      86
      87      if (^ isset(otype_ arg2)) go to error2;
      88
      89      smod = setmod(arg1, arg2);
      90
      91      return;
      92
      93
      94case_om;    $ om types - treat as errors
      95
      96/error1/            $ bad type for first argument
      97
      98      call err_type(10);
      99      smod = err_val(f_gen);
     100      return;
     101
     102
     103/error2/            $ incompatible argument types
     104
     105      call err_type(11);
     106      smod = err_val(f_gen);
     107      return;
     108
     109
     110      end fnct smod;
       1 .=member mult
       2      fnct mult(a1, a2, cpy);
       3
       4$ this is the general setl multiplication function. it performs short
       5$ multiplication in line and calls seperate lower level routines for eac
       6$ long type
       7
       8$ 'cpy' is a flag indicating what copying actions must be
       9$ performed on a1.
      10
      11
      12      size a1(hs),            $ specifiers for arguments
      13           a2(hs),
      14           cpy(ps);           $ copy flag
      15
      16      size mult(hs);          $ specifier returned
      17
      18      size arg1(hs),          $ local copies of arguments
      19           arg2(hs);
      20
      21      size val(hs);           $ temporary numeric value
      22
      23      real real1,             $ real temporaries
      24           real2;
      25
      26      size copy1(hs),         $ functions called
      27           sfloat(hs),
      28           multli(hs),
      29           multstr(hs),
      30           multtup(hs),
      31           intersect(hs),
      32           err_val(hs);
      33
      34
      35      arg1 = a1;   deref(arg1);
      36      arg2 = a2;   deref(arg2);
      37
      38
      39$ do any necessary copying
      40
      41      go to c(cpy) in copy_min to copy_max;
      42
      43
      44/c(copy_yes)/     $ copy arg1
      45
      46      arg1 = copy1(arg1);
      47
      48      go to esac;
      49
      50
      51/c(copy_test)/                $ copy -arg1- if it is shared
      52
      53      maycopy(arg1);
      54
      55      go to esac;
      56
      57
      58/c(copy_no)/       $ no copy necessary
      59
      60      go to esac;
      61
      62
      63/esac/                        $ branch on omega-type field of -arg1-
      64
      65      go to case(otype_ arg1) in t_min to t_max;
      66
      67
      68/case(t_int)/                 $ short integer
      69
      70      if otype_ arg2 = t_int then
      71          if .fb. otvalue_ arg1 + .fb. otvalue_ arg2 > .fb. maxsi then
      72              mult = multli(arg1, arg2);
      73          else
      74              build_spec(mult, t_int, ivalue_ arg1 * ivalue_ arg2)
      75          end if;
      76
      77      elseif otype_ arg2 = t_lint then
      78          mult = multli(arg1, arg2);
      79
stra 172      elseif otype_ arg2 = t_string ! otype_ arg2 = t_istring then
      81          mult = multstr(arg1, arg2);
      82
      83      elseif otype_ arg2 = t_tuple ! otype_ arg2 = t_stuple then
      84          mult = multtup(arg1, arg2);
      85
      86      else                    $ incompatible argument types
      87          go to error2;
      88      end if;
      89
      90      return;
      91
      92
stra 173/case(t_string)/              $ short character string
stra 174
stra 175      if (otype_ arg2 ^= t_int) go to error2;
stra 176
stra 177      mult = multstr(arg2, arg1);
stra 178
stra 179      return;
      94
stra 180/case(t_atom)/                $ error types
      96
      97/case(t_proc)/
      98
      99/case(t_lab)/
     100
     101/case(t_latom)/         $ error type - long atom
     102
     103/case(t_elmt)/       $ element - we should never reach here
     104
     105      go to error1;
     106
     107
     108/case(t_lint)/                $ long integers
     109
     110      if (otype_ arg2 ^= t_int & otype_ arg2 ^= t_lint) go to error2;
     111
     112      mult = multli(arg1, arg2);
     113
     114      return;
     115
     116
     117/case(t_istring)/             $ long character string
     118
     119      if (otype_ arg2 ^= t_int) go to error2;
     120
     121      mult = multstr(arg2, arg1);
     122
     123      return;
     124
     125
     126/case(t_real)/                $ reals
     127
     128      if (otype_ arg2 ^= t_real) go to error2;
     129
     130      real1 = rval(value_ arg1);
     131      real2 = rval(value_ arg2);
     132
     133      val = real1 * real2;
     134      put_realval(val, mult);
     135
     136      return;
     137
     138
     139/case(t_tuple)/               $ tuples
     140
     141/case(t_stuple)/
     142
     143      if (otype_ arg2 ^= t_int) go to error2;
     144
     145      mult = multtup(arg2, arg1);
     146
     147      return;
     148
     149
     150/case(t_set)/        $ sets and maps
     151
     152/case(t_map)/
     153
     154      if (^ isset(otype_ arg2)) go to error2;
     155
     156      mult = intersect(arg1, arg2);
     157
     158      return;
     159
     160
     161case_om                       $ omega ceses - treat as errors
     162
     163/error1/                      $ illegal first argument type
     164
     165      call err_type(12);
     166      mult = err_val(f_gen);
     167
     168      return;
     169
     170
     171/error2/                      $ incompatible argument types
     172
     173      call err_type(13);
     174      mult = err_val(f_gen);
     175
     176      return;
     177
     178
     179      end fnct mult;
       1 .=member multstr
       2      fnct multstr(a1, a2);
       3
       4$ this routine performs -a1 * a2-, where -a1- is a short integer and
       5$ -a2- is a string.  the result is a string obtained by concatenating
       6$ -a2- to itself -a1- times.  since this operation is rather rare,
       7$ it is actually done by a series of concatenations.
       8
       9$ n.b.   (1.)  -a1- is the specifier for a short integer.
      10$        (2.)  -a2- is the specifier for a long character string.
      11$        (3.)  -a2- is not used destructively.
      12
      13
      14      size a1(hs),            $ specifier for integer
      15           a2(hs);            $ specifier for string
      16
      17      size multstr(hs);       $ specifier returned
      18
stra 181      size ss1(ssz);          $ string specifier for result
stra 182      size ofs1(ps);          $ offset in result
stra 183      size len1(ps);          $ length of result
stra 184      size tp2(ps);           $ otype of string operand
stra 185      size ss2(ssz);          $ string specifier for string operand
stra 186      size len2(ps);          $ length of string operand
stra 187      size c(cs);             $ current character
stra 188      size n(ps);             $ integer value of -a1-
stra 189      size j(ps);             $ loop index
      21
stra 190      size nulllc(ssz);       $ allocates null string
      25
      26
stra 191      tp2 = otype_ a2;
stra 192
stra 193      if tp2 = t_string then  $ string operand is short
stra 194          len2 = sc_nchars_ a2;  $ get length of string operand
stra 195          c = scchar(a2, 1);  $ get character
stra 196      elseif tp2 = t_istring then  $ string operand is long
stra 197          ss2 = value_ a2;  $ get string specifier
stra 198          len2 = ss_len(ss2);  $ get length of string operand
stra 199      else    $ illegal string operand
stra 200          multstr = err_val(f_string);
stra 201          return;
stra 202      end if;
      28
stra 203      n = ivalue_ a1;  $ get number of replications
stra 204      len1 = n * len2;  $ compute length of result
stra 205
stra 206      if len1 = 0 then  $ result is null string
stra 207          build_spec(multstr, t_string, 0);
stra 208          return;
stra 209      end if;
stra 210
stra 211      ss1 = nulllc(len1);  $ allocate result string block
stra 212      ofs1 = ss_ofs(ss1);  $ initial offset in result
      30
stra 213      if tp2 = t_string then  $ string operand is short
stra 214          do j = 1 to n;  icchar(ss1, j) = c;  end do;
stra 215      else    $ string operand is long
stra 216          do j = 1 to n;
stra 217              mvc(ss1, ss2, len2);  $ append string arg to result
stra 218              ofs1 = ofs1 + len2; ss_ofs(ss1) = ofs1;  $ advance
stra 219          end do;
stra 220          ss_ofs(ss1) = ofs1 - len1;  $ reset to point to start
stra 221      end if;
stra 222
stra 223      $ build result specifier
stra 224      ss_len(ss1) = len1;  $ set length of result
stra 225      build_spec(multstr, t_istring, ss1);  $ build specifier
      34
      35
      36      end fnct multstr;
       1 .=member multtup
       2      fnct multtup(a1, a2);
       3
       4$ this routine performs -a1 * a2-, where -a1- is a short integer and
       5$ -a2- is a tuple.  the result is a tuple obtained by concatenating
       6$ -a2- to itself -a1- times.  since this operation is rather rare,
       7$ it is actually done by a series of concatenations.
       8
       9$ n.b.   (1.)  -a1- is the specifier for a short integer.
      10$        (2.)  -a2- is the specifier for a tuple.
      11$        (3.)  -a2- is not used destructively.
      12
      13
      14      size a1(hs),            $ specifier for integer
      15           a2(hs);            $ specifier for tuple
      16
      17      size multtup(hs);       $ specifier returned
      18
      19      size arg2(hs);          $ local copy of -a2-
      20      size val(ps),           $ value of -a1-
      21           j(ps);             $ loop index
      22
      23      size addtup(hs),        $ functions called
      24           nulltup(hs),
      25           err_val(hs);
      26      size convert(hs);       $ conversion utility
      27
      28
      29      val = ivalue_ a1;
      30
      31      if ft_type(hform(value_ a2)) = f_mtuple then
      32          multtup = nulltup(f_tuple, val); arg2 = convert(a2, f_tuple);
      33      else
      34          multtup = nulltup(hform(value_ a2), val); arg2 = a2;
      35      end if;
      36
      37      do j = 1 to val;
      38          multtup = addtup(multtup, arg2);
      39      end do;
      40
      41
      42      end fnct multtup;
       1 .=member union
       2      fnct union(arg1, arg2, decl);
       3
       4$ general set union function.
       5
       6$ union, intersection, and set difference are variations of the same
       7$ algorithm. each of these primitives is relatively simple when
       8$ applied to sets, subsets, packed maps, and untyped maps, but quite
       9$ complex when applied to multi valued maps. for this reason operations
      10$ on each of the simpler types are done from seperate routines which
      11$ can be called from the general union (etc) routine or directly from
      12$ the code. the general routines contain code to handle general maps
      13$ plus code to call the lower level routines.
      14
      15$ adding two maps requires the following steps:
      16
      17$ 1. find some matching element x in the domain of set1 and set2.
      18$    set a1 = set1(x) and a2 = set2(x). call the local routine
      19$    add_im.
      20
      21$ 2. if either or both of its arguments are single valued, add_im
      22$    will set 'union' to their union. in this
      23$    process either a1 or a2 may become part of the result. for
      24$    a1 this is no problem, since set1 is being used destructively
      25$    anyway.  if, however, a2 is included in the result, we must
      26$    make a note to set its share bit in set2. this is done by
      27$    setting the flag share2 = yes.
      28
      29$ 3. if both a1 and a2 are multivalued, add_im will copy a1 cond-
      30$    itionally and jump to the recursive entry point. since this
      31$    is a go to rather than a call, the recursive call will return
      32$    directly to add_ims caller.
      33
      34$ 4. add_im must detect the special case where an smap is becoming
      35$    multivalued. if the inputs are smaps we must convert them
      36$    to general maps. this is possbible only if the inputs are
      37$    undeclared (decl = no).
      38
      39$ 5. on return from add_im, we set set1(x) = union. if share2 is
      40$    set, we also set the is_shared bit of set2(x).
      41
      42$ union is called in two contexts, as indicated by 'decl':
      43
      44$ 1. the returned value, arg1, and arg2 have all been declared
      45$    to be of some common mode m.
      46
      47$ 2. the returned value, arg1, and arg2 are undeclared. their
      48$    are two possibilities here:
      49
      50$    a. arg1 and arg2 have some common mode m, so we return a
      51$       value of mode m.
      52
      53$    b. arg1 and arg2 have different modes. we convert both
      54$       to unbased set(*) and return a result of unbased set(*).
      55
      56$ in both cases we assume that a1 can be used destructively.
      57
      58
      59$ union computes the nelt of its result at every recursive level, and
      60$ trusts the nelt field to be valid after a recursive return, regardless
      61$ of the setting of is_neltok.
      62
      63
      64      size arg1(hs);          $ specifier for first input
      65      size arg2(hs);          $ specifier for second argument
      66      size decl(1);           $ indicates inputs are declared
      67
      68      size union(hs);         $ specifier returned
      69
      70      size a1(hs);            $ local copies of arguments, used for
      71      size a2(hs);            $ recursion.
      72      size d2(hs);            $ domain element of set2
      73      size tstart(ps);        $ pointer to recursion stack at start
      74      size im_nelt(ps);       $ the nelt of a map image
      75      size pos(ps);           $ value return argument to locate
      76
      77      size unset(hs),   unlset(hs),  unrset(hs);
      78      size unlpm(hs),   unlum(hs),   unrpm(hs),   unrum(hs);
      79      size exprmap(ps);
      80      size copy1(hs);
      81      size withs(hs);
      82      size equal(1);
      83      size convert(hs);
      84      size rset2(hs);
      85
      86$ stacked variables
      87
      88 .=zzyorg b $ reset counters for stack offsets
      89
      90      local(retpt);           $ return pointer
      91
      92      local(set1);            $ pointers to two sets.
      93      local(set2);
      94      local(card);            $ cardinality of result
      95      local(e);               $ pointer to current eb
      96      local(p1);              $ pointer to an element of set1
      97      local(p2);              $ pointer to an element of set2
      98      local(j);               $ loop index over tuple
      99      local(lsw1);            $ ls_words of two local maps
     100      local(lsw2);
     101      local(share2);          $ flags sharing of an element of set2.
     102      local(tup1);            $ pointers to tuples of remote maps
     103      local(tup2);
     104      local(len1);            $ lengths of the tuples
     105      local(len2);
     106      local(min);             $ minimum of p1 and p2
     107
     108
     109      tstart = t;             $ save initial stack pointer
     110
     111 .=zzyorg a     $ reset counter for return labels
     112
     113      a1 = arg1;              $ copy specifiers
     114      a2 = arg2;
     115
     116
     117/entry/                       $ recursive entry point
     118
     119      r_entry;                $ increment recursion stack
     120
     121      set1 = value_ a1;       $ get pointers to sets
     122      set2 = value_ a2;
     123
     124$ check that types match
     125
     126$ if the forms of the arguments are not similar, convert them to
     127$ set(*).
     128
     129      if ^ similar_repr(hform(set1), hform(set2)) then
     130          call convset(a1);   set1 = value_ a1;
     131          call convset(a2);   set2 = value_ a2;
     132      end if;
     133
     134
     135      go to sc(htype(set1)) in h_uset to h_lrmap;
     136
     137
     138/sc(h_uset)/                  $ standard set
     139
     140      union = unset(a1, a2);
     141      go to exit;
     142
     143
     144/sc(h_umap)/                  $ standard map
     145
     146$ we iterate over the domain of set2, locating corresponding domain
     147$ elements in set1. we then add their images using the alogorithm
     148$ described at the beginning of the routine.
     149
     150$ in most cases we can calculate the cardinality of the result as we
     151$ go. however in this case we will not be iterating over both sets,
     152$ so we must calculate nelt after we are done.
     153
     154      next_loop(p2, set2);    $ (forall p2 in set2)
     155          d2 = ebspec(p2);
     156          call locate(pos, d2, set1, yes);
     157          ebspec(p2) = d2;    $ might have its share bit set
     158          p1         = pos;   $ save across recursion
     159
     160          a1 = ebimag(p1);    $ get images
     161          a2 = ebimag(p2);
     162
     163          l_call(add_im);     $ add images
     164
     165$ if a2 is put into the image of set1, its share bit must be set.
     166          if (share2) is_shared_ ebimag(p2) = yes;
     167
     168          ebimag(p1) = union; $ store image and adjust nelt
     169      end_next;
     170
     171      is_hashok(set1) = no;
     172
     173      build_spec(union, t_map, set1);  $ build result
     174      ok_nelt(union);  $ get the correct nelt
     175
     176      go to exit;
     177
     178
     179/sc(h_lset)/                  $ local subsets
     180
     181      union = unlset(a1, a2);
     182      go to exit;
     183
     184
     185/sc(h_rset)/                  $ remote subset
     186
     187      union = unrset(a1, a2);
     188      go to exit;
     189
     190
     191/sc(h_lmap)/                  $ local map
     192
     193$ we iterate over the common base, adding the images of each domain
     194$ element.
     195
     196      lsw1 = ls_word(set1);   $ get ls_words.
     197      lsw2 = ls_word(set2);
     198      card = 0;               $ cardinality of result
     199
     200      next_loop(e, set1);     $ (forall e in set1)
     201
     202          $ form union of images of e.
     203          a1 = heap(e+lsw1);
     204          a2 = heap(e+lsw2);
     205          l_call(add_im);
     206
     207          $ set share bit of a2 in set2.
     208          if (share2) is_shared(e+lsw2) = yes;
     209
     210          heap(e+lsw1) = union;  $ store image and adjust nelt
     211          card = card+im_nelt;
     212
     213      end_next;
     214
     215      set_nelt(set1, card);
     216      is_hashok(set1) = no;
     217
     218      build_spec(union, t_map, set1);  $ build result
     219
     220      go to exit;
     221
     222
     223/sc(h_rmap)/                  $ remote map
     224
     225$ iterate over the two maps, taking the union of corresponding
     226$ tuple components.
     227
     228      card = 0;               $ cardinality of result
     229
     230      tup1 = set1 + hl_rmap;
     231      tup2 = set2 + hl_rmap;
     232
     233      $ get lengths of tuples, and make sure set1 is as long as set2
     234      len1 = maxindx(tup1);
     235      len2 = maxindx(tup2);
     236
     237      if len2 > len1 then     $ tup1 is shorter
     238          len1 = len2;
     239          set1 = exprmap(set1, len2);   tup1 = set1 + hl_rmap;
     240      end if;
     241
     242      min = len1;  $ length of shorter tuple
     243      if (min > len2) min = len2;
     244
     245$ we will have two loops, first over the length of the shorter tuple,
     246$ then over the remaining length of tup1. set the limits for these
     247$ loops.
     248
     249      j = 1;     $ loop index over components
     250
     251      while j <= min;
     252          a1 = tcomp(tup1, j);
     253          a2 = tcomp(tup2, j);
     254
     255          l_call(add_im);  $ add images
     256
     257$ set share bit of a2 in set2.
     258          if (share2) is_shared_ tcomp(tup2, j) = yes;
     259
     260          tcomp(tup1, j) = union;  $ store image and adjust nelt
     261          card = card+im_nelt;
     262
     263          j = j+1;
     264      end while;
     265
     266
     267$ add the remaining components of tup1 into nelt of result
     268
     269      while j <= maxindx(tup1);
     270          a1 = tcomp(tup1, j);
     271          j = j+1;
     272
     273          if is_multi_ a1 then
     274              ok_nelt(a1);
     275              card = card + nelt(value_ a1);
     276
     277          else
     278              if (^ is_om_ a1) card = card+1;
     279          end if;
     280
     281      end while;
     282
     283
     284      set_nelt(set1, card);
     285
     286      is_hashok(set1) = no;
     287
     288
     289      build_spec(union, t_map, set1); $ build result
     290
     291      go to exit;
     292
     293
     294/sc(h_lpmap)/          $ local packed map
     295
     296      union = unlpm(a1, a2);
     297      if (union = 0) go to smap;  $ became multivalued
     298      go to exit;
     299
     300
     301/sc(h_limap)/          $ local untyped maps
     302
     303/sc(h_lrmap)/
     304
     305      union = unlum(a1, a2);
     306      if (union = 0) go to smap;  $ smap became multivalued
     307      go to exit;
     308
     309
     310/sc(h_rpmap)/          $ packed remote map
     311
     312      union = unrpm(a1, a2);
     313      if (union = 0) go to smap;  $ smap became multivalued
     314      go to exit;
     315
     316
     317/sc(h_rimap)/          $ remote untyped maps
     318
     319/sc(h_rrmap)/
     320
     321
     322      union = unrum(a1, a2);
     323      if (union = 0) go to smap;  $ smap became multivalued
     324      go to exit;
     325
     326
     327
     328
     329
     330/add_im/                 $ local routine to add images
     331
     332$ this local routine adds two map images, a1 and a2, and places the
     333$ result in -union-. it also calculates the nelt of the result and
     334$ places it in -im_nelt-. it sets the flag -share2- to indicate
     335$ whether or not a2 has been shared. this allows us to set the
     336$ share bit in the map which contains a2.
     337
     338$ the code below tests for various cases which can be done without
     339$ a recursive call. if a recursive call is necessary, we jump to
     340$ the main recursive entry point.
     341
     342      share2 = no;  $ assume a2 is not shared
     343
     344      if is_om_ a1 then  $ a1 is om, so return a2
     345          is_shared_ a2 = yes;   share2 = yes;
     346          union = a2;
     347
     348      elseif is_om_ a2 then  $ a2 is om, so return a1
     349          union = a1;
     350
     351      elseif is_multi_ a1 & ^ is_multi_ a2 then    $ return a1 with a2
     352
     353          maycopy(a1);
     354          is_shared_ a2 = yes;   share2 = yes;
     355
     356          union = withs(a1, a2, no);
     357          is_multi_ union = yes;
     358
     359      elseif is_multi_ a2 & ^ is_multi_ a1 then  $ return a2 with a1
     360          if (is_smap(set1)) go to smap;   $ must convert smap
     361
     362          is_shared_ a1 = yes;
     363          union = withs(copy1(a2), a1, no);
     364          is_multi_ union = yes;
     365
     366      elseif is_multi_ a1 & is_multi_ a2 then  $ both multivalued.
     367          if eq(a1, a2) then   $ trivially equal, i.e. both null
     368              union = a1;
     369          else
     370              maycopy(a1);
     371              go to entry;
     372          end if;
     373
     374
     375      elseif eq(a1, a2) then  $ they-re equal, so return a1
     376          union = a1;
     377
     378      elseif ne(a1, a2) then  $ unequal
     379          if (is_smap(set1)) go to smap;    $ must convert smap
     380
     381          is_shared_ a2 = yes;   share2 = yes;
     382          union = rset2(a1, a2);  $ return << a1, a2 >>
     383          is_multi_ union = yes;
     384
     385      elseif equal(a1, a2) then  $ equal, return a1
     386          union = a1;
     387
     388      else    $ unequal
     389          if (is_smap(set1)) go to smap;  $ convert smap
     390
     391          is_shared_ a2 = yes;   share2 = yes;
     392          union = rset2(a1, a2);  $ return << a1, a2 >>
     393          is_multi_ union = yes;
     394      end if;
     395
     396$ get nelt of result
     397      if is_multi_ union then
smfc  21          if is_mmap(set1) = no
smfc  22                  & hform(value_ union) ^= ft_imset(hform(set1)) then
smfc  23              union = convert(union, ft_imset(hform(set1)));
smfc  24              is_multi_ union = yes;
smfc  25          end if;
     398          ok_nelt(union);
     399          im_nelt = nelt(value_ union);
     400
     401      elseif is_om_ union then
     402          im_nelt = 0;
     403
     404      else
     405          im_nelt = 1;
     406      end if;
     407
     408
     409      go to rlab(retpt) in 1 to zzya;
     410
     411
     412/smap/      $ an smap is no longer single valued
     413
     414$ if the map was declared, abort. otherwise convert both
     415$ inputs to standard maps, and try again.
     416
     417      if (decl) go to error_exit;
     418
     419$ build specifiers for the inputs, then convert
     420      build_spec(a1, t_map, set1);
     421      build_spec(a2, t_map, set2);
     422
     423      a1 = convert(a1, f_umap);   set1 = value_ a1;
     424      a2 = convert(a2, f_umap);   set2 = value_ a2;
     425
     426      go to sc(h_umap);  $ go to unbased map case
     427
     428
     429/exit/                     $ recursive return
     430
     431      r_exit;  $ pop recursion stack
     432
     433      if t ^= tstart then
     434          is_multi_ union = yes;    $ set mmap bit of result
     435          im_nelt = nelt(value_ union);  $ nelt of image
     436
     437          go to rlab(retpt) in 1 to zzya;
     438
     439      else                      $ actual return
     440          return;
     441      end if;
     442
     443/error_exit/                  $ error exit
     444
     445      call err_misc(25);
     446
     447      union = err_val(f_gen);
     448
     449      t = tstart;
     450      return;
     451
     452
     453
     454$ drop local variables
     455
     456      macdrop8(retpt, set1, set2, card, p1, p2, lsw1, lsw2)
     457      macdrop8(share2, tup1, tup2, len1, len2, min, j, e)
     458
     459      end fnct union;
       1 .=member unset
       2      fnct unset(arg1, arg2);   $ union on standard sets
       3
       4
       5      size unset(hs);      $ specifier returned
       6
       7      size arg1(hs),     $ specifiers for two sets
       8           arg2(hs);
       9
      10
      11      size set1(ps),    $ pointers to two sets
      12           set2(ps);
      13
      14      size p1(ps),    $ pointers to current ebs of two sets
      15           p2(ps);
      16
      17
      18      set1 = value_ arg1;  $ get pointers to sets
      19      set2 = value_ arg2;
      20$ set union is done by iterating over set2, adding elements to set1.
      21$ if set2 is live then we must set share bits in set2 every time we
      22$ add an element to set1.
      23
      24$ as we add elements to set1, we will increment its hash by the hash
      25$ of the element. the hash is computed when we perform the locate, and
      26$ is passed globally through loc_hash.
      27
      28      next_loop(p2, set2);      $  (! p2 _ set2 )
      29
      30          call locate(p1, ebspec(p2), set1, yes);
      31       $ if heap(p2) was added to set1, set share bit in set2.
      32$ and increment the hash of set1.
      33          if ^ loc_found then
      34              is_shared_ ebspec(p2) = yes;
      35              up_hash(set1, loc_hash);
      36          end if;
      37
      38      end_next;
      39
      40      set_nelt(set1, neb(hashtb(set1)));
      41
      42      build_spec(unset, t_set, set1);
      43
      44
      45      end fnct unset;
       1 .=member unlset
       2      fnct unlset(a1, a2);    $ union on local sets
       3
       4
       5      size unlset(hs);      $ specifier returned
       6
       7      size a1(hs),   $ specifiers for two sets
       8           a2(hs);
       9
      10      size set1(ps),  $ pointers to two sets
      11           set2(ps);
      12
      13      size lsw1(ps),    $ their ls_words
      14           lsw2(ps),
      15           lsb1(ps),    $ their ls_bits
      16           lsb2(ps);
      17
      18      size bit1(1),   $ current bit of set1
      19           bit2(1),  $ bit of set2
      20           bit(1);  $ bit of result
      21
      22      size card(ps),   $ cardinality of result
      23           hashc(ps);  $ hash of result
      24
      25      size e(ps);     $ pointer to current eb of base.
      26
      27
      28      set1 = value_ a1;  $ get pointers to sets
      29      set2 = value_ a2;
      30$ we iterate over the common base, or-ing the bits corresponding to
      31$ each set element.as we add each element to set1, we get it hash from
      32$ the base and add it to the hash of set1.
      33
      34      lsw1 = ls_word(set1);   $ get ls_words and ls_bits.
      35      lsb1 = ls_bit(set1);
      36
      37      lsw2 = ls_word(set2);
      38      lsb2 = ls_bit(set2);
      39
      40
      41      card = 0;   $ cardinality of result.
      42      hashc = hc_set;   $ hash of null set
      43
      44      next_loop(e, set1);        $ iterate over base
      45
      46          bit1 = .f. lsb1, 1, heap(e+lsw1);
      47          bit2 = .f. lsb2, 1, heap(e+lsw2);
      48
      49          bit = (bit1 ! bit2);
      50
      51          card = card+bit;
      52          if (bit) hashc = hashc + ebhash(e); $ add hash from base
      53
      54          .f. lsb1, 1, heap(e+lsw1) = bit;
      55
      56      end_next;
      57
      58      set_nelt(set1, card);
      59      set_hash(set1, hashc);
      60
      61      build_spec(unlset, t_set, set1);
      62
      63
      64      end fnct unlset;
       1 .=member unrset
       2      fnct unrset(arg1, arg2);  $ union on remote sets
       3
       4
       5      size unrset(hs);   $ specifier returned
       6
       7      size arg1(hs),   $ specifiers for two sets
       8           arg2(hs);
       9
      10      size set1(ps),   $ pointers to two sets
      11           set2(ps);
      12
      13      size p1(ps),   $ pointers to their bit strings
      14           p2(ps);
      15
      16      size len1(ps),   $ lengths of bit strings
      17           len2(ps);
      18
      19      size j(ps),  $ loop index
      20           word(hs);  $ current word of bit string
      21
      22      size exprset(ps);   $ function called
      23
      24
      25      set1 = value_ arg1;  $ get pointers to sets
      26      set2 = value_ arg2;
      27
      28$ we begin by making set1 the longer bit string and then or in
      29$ all the words of set2. we calculate -card- as the number of
      30$ bits on in set1.
      31
      32$ unlike some of the other union routines, we do not update the hash
      33$ of the set. this is not done since we do not look at each element
      34$ individually.
      35
      36      len1 = rswords(set1);
      37      len2 = rswords(set2);
      38
      39      if len1 < len2 then      $ expand set1
      40          set1 = exprset(set1, rs_maxi(set2)); len1 = len2;
      41      end if;
      42
      43$ take the union
      44
      45      do j = 1 to len2;
      46          word = (rsword(set1, j) ! rsword(set2, j));
      47          rsword(set1, j) = word;
      48      end do;
      49
      50      is_neltok(set1) = no;
      51      is_hashok(set1) = no;
      52
      53      build_spec(unrset, t_set, set1);
      54
      55
      56      end fnct unrset;
       1 .=member unlpm
       2      fnct unlpm(a1, a2);  $ union on local packed maps
       3
       4$ this routine performs union on local packed maps. it returns 0
       5$ if the result becomes multivalued.
       6
       7
       8      size unlpm(hs);    $ specifier returned
       9
      10      size a1(hs),   $ specifiers for two sets
      11           a2(hs);
      12
      13      size set1(ps),    $ pointers to the sets
      14           set2(ps);
      15
      16      size lsw1(ps),      $ their ls_words
      17           lsw2(ps),
      18           lsb1(ps),    $ their ls_bits
      19           lsb2(ps);
      20
      21      size bits(ps),    $ number of bits/value
      22           card(ps),     $ cardinality of result
      23           e(ps);   $ pointer to current eb of base
      24
      25      size v1(hs),    $ current packed values
      26           v2(hs);
      27
      28
      29      set1 = value_ a1;  $ get pointers to sets
      30      set2 = value_ a2;
      31$ iterate over base taking union of elements.
      32
      33      lsw1 = ls_word(set1);  $ get ls_word and ls_bit values.
      34      lsw2 = ls_word(set2);
      35
      36      lsb1 = ls_bit(set1);
      37      lsb2 = ls_bit(set2);
      38
      39      bits = ls_bits(set1);  $ bits per entry
      40
      41      card = 0;        $ cardinality of result
      42
      43      next_loop(e, set1);
      44
      45          v1 = .f. lsb1, bits, heap(e+lsw1);  $ get packed valu
      46          v2 = .f. lsb2, bits, heap(e+lsw2);
      47
      48          if v1 = 0 & v2 = 0 then $ both om
      49              cont;
      50
      51          elseif v1 = 0 then  $ union is v2
      52              .f. lsb1, bits, heap(e+lsw1) = v2;
      53              card = card+1;
      54
      55          elseif v2 = 0 then  $ union is v1, which is already in set1.
      56              card = card+1;
      57
      58          elseif v1 = v2 then  $ union is v1, which is already in set1
      59              card = card+1;
      60
      61          else            $ map would become multivalued.
      62              unlpm = 0;  $ flag becoming multivalued
      63              return;
      64          end if;
      65      end_next;
      66
      67      set_nelt(set1, card);
      68
      69      is_hashok(set1) = no;
      70
      71      build_spec(unlpm, t_map, set1);
      72
      73
      74      end fnct unlpm;
       1 .=member unlum
       2      fnct unlum(arg1, arg2);
       3
       4$ this routine performs union on local untyped maps. it returns 0
       5$ if the result becomes multivalued.
       6
       7
       8      size unlum(hs);    $ specifier returned
       9
      10      size arg1(hs),    $ specifiers for two sets
      11           arg2(hs);
      12
      13      size a1(hs),   $ tuple components
      14           a2(hs);
      15
      16      size set1(ps),   $ pointers to two sets
      17           set2(ps);
      18
      19      size om_val(hs),     $ proper om value for components
      20           card(ps),     $ cardinality of result
      21           e(ps);   $ pointer to current eb of base
      22
      23      size lsw1(ps),   $ ls_words of the arguments
      24           lsw2(ps);
      25
      26
      27      set1 = value_ a1;  $ get pointers to sets
      28      set2 = value_ a2;
      29
      30
      31      lsw1 = ls_word(set1);  $ get ls_words
      32      lsw2 = ls_word(set2);
      33
      34$ get om image as it would appear in map
      35      om_val = heap(template(set1)+lsw1);
      36
      37      card = 0;  $ cardinality of result
      38
      39                   $ loop over base
      40      next_loop(e, set1);
      41
      42          a1 = heap(e+lsw1);
      43          a2 = heap(e+lsw2);
      44
      45          if a1 = om_val & a2 = om_val then
      46              cont;
      47
      48          elseif a1 = om_val then   $ union is a2.
      49              heap(e+lsw1) = a2;
      50              card = card+1;
      51
      52          elseif a2 = om_val then
      53              card = card+1;
      54
      55          else      $ map would become multivalued.
      56              unlum = 0;  $ flag becoming multivalued
      57              return;
      58          end if;
      59      end_next;
      60
      61      set_nelt(set1, card);
      62
      63      is_hashok(set1) = no;
      64
      65      build_spec(unlum, t_map, set1);
      66
      67
      68      end fnct unlum;
       1 .=member unrpm
       2      fnct unrpm(arg1, arg2);  $ union on remote packed map
       3
       4$ this routine performs union on remote packed maps. it returns 0
       5$ if the map becomes multivalued.
       6
       7
       8      size unrpm(hs);     $ specifier returned
       9
      10      size a1(hs),     $ specifiers for two sets
      11           a2(hs);
      12
      13      size set1(ps),    $ pointers to two sets
      14           set2(ps),
      15           p1(ps),    $ pointers to their tuples
      16           p2(ps);
      17
      18      size len1(ps),    $ lengths of the two tuples
      19           len2(ps),
      20           min(ps),  $ minimum of len1 and len2
      21           v1(ps),     $ their packed values
      22           v2(ps);
      23
      24      size bits(ps),    $ bits/packed value
      25           card(ps),    $ cardinality of resut
      26           j(ps),    $ loop index over words of tuple
      27           org(ps);    $ loop index over bit origin in word
      28
      29      size exprmap(ps);  $ function called
      30
      31
      32      set1 = value_ a1;  $ get pointers to sets
      33      set2 = value_ a2;
      34
      35
      36$ we use a double loop over the tuples, one for sucessive words and
      37$ one for successive elements in a word.
      38
      39      card = 0;         $ cardinality of result
      40
      41      p1 = set1 + hl_rpmap;
      42      p2 = set2 + hl_rpmap;
      43
      44      len1 = maxindx(p1);  $ get lengths
      45      len2 = maxindx(p2);
      46
      47
      48$ make sure that set1 has as long a tuple as set2, then set 'min' to
      49$ the minimum length. the components 1 to min will be the union of
      50$ the two sets; the components min+1 to length(set1) will be taken
      51$ from set1.
      52
      53      if len1 < len2 then
      54          len1 = len2;
      55          set1 = exprmap(set1, len1);
      56      end if;
      57
      58      min = len1;
      59      if (min > len2) min = len2;
      60
      61      bits = ptbits(p1);  $ bits/packed value
      62
      63$ take union over minimum length
      64      do j = hl_ptuple to packoffs(p1, min);
      65
      66          do org = 1 to bpos_max by bits;
      67
      68              v1 = .f. org, bits, heap(p1+j);
      69              v2 = .f. org, bits, heap(p2+j);
      70
      71              if v1 = 0 & v2 = 0 then  $ union is om
      72                  cont;
      73
      74              elseif v1 = 0 then  $ union is v2
      75                  .f. org, bits, heap(p1+j) = v2;
      76                  card = card+1;
      77
      78              elseif v2 = 0 then  $ union is v1
      79                  card = card+1;
      80
      81              elseif v1 = v2 then    $ union is a1
      82                  card = card+1;
      83
      84              else            $ map is becoming multivalued.
      85                  unrpm = 0;  $ flag becoming multivalued
      86                  return;
      87              end if;
      88          end do;
      89      end do;
      90
      91$ increment cardinality by the remaining elements of set1.
      92
      93      do j = packoffs(p2, min)+1 to packoffs(p1, len1);
      94          do org = 1 to bpos_max by bits;
      95
      96              if (.f. org, bits, heap(p1+j) ^= 0) card = card+1;
      97
      98          end do;
      99      end do;
     100
     101      set_nelt(set1, card);
     102
     103      is_hashok(set1) = no;
     104
     105      build_spec(unrpm, t_map, set1);
     106
     107
     108      end fnct unrpm;
       1 .=member unrum
       2      fnct unrum(arg1, arg2);
       3
       4$ this routine performs union on remote untyped maps. it returns 0
       5$ if the result becomes multivalued.
       6
       7
       8      size unrum(hs);      $ specifier returned
       9
      10      size arg1(hs),      $ specifiers for two sets
      11           arg2(hs);
      12
      13      size set1(ps),     $ pointers to the sets
      14           set2(ps),
      15           tup1(ps),      $ pointers to their tuples
      16           tup2(ps);
      17
      18      size len1(ps),    $ length of the tuples
      19           len2(ps),
      20           min(ps);  $ minimum of len1 and len2
      21
      22      size card(ps),     $ cardinality of result
      23           om_val(hs),    $ om value
      24           j(ps);    $ loop index over tuple components
      25
      26      size a1(hs),    $ tuple components
      27           a2(hs);
      28
      29      size exprmap(ps);  $ function called
      30
      31
      32      set1 = value_ a1;  $ get pointers to sets
      33      set2 = value_ a2;
      34
      35      card = 0;         $ cardinality of result
      36
      37      tup1 = set1+1;      $ get pointers to tuples
      38      tup2 = set1+1;
      39
      40      len1 = maxindx(tup1);  $ get thier lengths.
      41      len2 = maxindx(tup2);
      42
      43$ make sure set1 has as long a tuple as set2, then set min to the
      44$ minimum length.
      45      if len1 < len2 then
      46          len1 = len2;
      47          set1 = exprmap(set1, len1);
      48          tup1 = set1 + hl_rmap;
      49      end if;
      50
      51      min = len1;
      52      if (min > len2) min = len2;
      53
      54$ get om image value as it would appear in the tuple
      55      om_val = tcomp(tup1, 0);
      56
      57$ take union over length of shorter tuple
      58      do j = 1 to min;
      59
      60          a1 = tcomp(tup1, j);
      61          a2 = tcomp(tup2, j);
      62
      63          if a1 = om_val & a2 = om_val then  $ union is om
      64              cont;
      65
      66          elseif a1 = om_val then  $ union is a2
      67              tcomp(tup1, j) = a2;
      68              card = card+1;
      69
      70          elseif a2 = om_val then  $ union is a1
      71              card = card+1;
      72
      73          elseif a1 = a2 then    $ union is a1
      74              card = card+1;
      75
      76          else            $ map is becoming multivalued.
      77              unrum = 0;  $ flag becoming multivalued
      78              return;
      79          end if;
      80      end do;
      81
      82$ increment cardinality by remaining elements of set1.
      83
      84      do j = min+1 to len1;
      85
      86          if (tcomp(tup1, j) ^= om_val) card = card+1;
      87
      88      end do;
      89
      90      set_nelt(set1, card);
      91
      92      is_hashok(set1) = no;
      93
      94      build_spec(unrum, t_map, set1);
      95
      96
      97      end fnct unrum;
       1 .=member intersect
       2      fnct intersect(arg1, arg2);
       3
       4
       5
       6$ union, intersection, and set difference are variations of the same
       7$ algorithm. each of these primitives is relatively simple when
       8$ applied to sets, subsets, packed maps, and untyped maps, but quite
       9$ complex when applied to multi valued maps. for this reason operations
      10$ on each of the simpler types are done from seperate routines which
      11$ can be called from the general union (etc) routine or directly from
      12$ the code. the general routines contain code to handle general maps
      13$ plus code to call the lower level routines.
      14
      15
      16$ the intersection routine begins with a branch on type. the code
      17$ for those types which may require recursion is contained in line;
      18$ the code for other types is found in seperate routines.
      19
      20$ multiplying two maps requires the following steps:
      21
      22$ 1. find some matching element x in the domain of set1 and set2.
      23$    set a1 = set1(x) and a2 = set2(x). call the local routine
      24$    mult_im.
      25
      26$ 2. if either or both of its arguments are single valued, mult_im
      27$    will set 'intersect' to their intersection. in this
      28$    process either a1 or a2 may become part of the result. for
      29$    a1 this is no problem, since set1 is being used destructively
      30$    anyway. howeverif a2 is included in the result, we must
      31$    make a note to set its share bit in set2. this is done by
      32$    setting the flag share2 = yes.
      33
      34$ 3. if both a1 and a2 are multivalued, we jump to the take their
      35$   intersection recursively. we do this by jumping to the recursive
      36$   entry point. after the recursive call, we will return directly to
      37$   mult_im-s caller.
      38
      39$ 4. on return from mult_im, we set set1(x) = intersect. if necessary,
      40$    we also set the share bit of set2(x).
      41
      42$ inter is called in one of two contexts:
      43
      44$ 1. the returned value, arg1, and arg2 have all been declared
      45$    to be of some common mode m.
      46
      47$ 2. the returned value, arg1, and arg2 are undeclared. their
      48$    are two possibilities here:
      49
      50$    a. arg1 and arg2 have some common mode m, so we return a
      51$       value of mode m.
      52
      53$    b. arg1 and arg2 have different modes. we convert both
      54$       to unbased set(*) and return a result of unbased set(*).
      55
      56$ in both cases we assume that a1 can be used destructively.
      57
      58
      59$ intersect computes the nelt of its result at every recursive level, an
      60$ trusts the nelt field to be valid after a recursive return, regardless
      61$ of the setting of is_neltok.
      62
      63      size intersect(hs);     $ specifier returned
      64
      65      size arg1(hs);          $ specifier for first input
      66      size arg2(hs);          $ specifier for second argument
      67
      68      size a1(hs),          $ local copies of arguments, used for
      69           a2(hs);          $ recursion.
      70
      71
      72      size tstart(ps);  $ pointer to recursion stack at start of routin
      73
      74      size im_nelt(ps);  $ nelt of map image. this is an auxilliary
      75                          $ output of the routine.
      76
      77      size pos(ps);  $ value return parameter to locate
      78
      79      size inset(hs),  $ functions called
      80           inlset(hs),
      81           inrset(hs),
      82           inlpm(hs),
      83           inlum(hs),
      84           inrpm(hs),
      85           inrum(hs),
      86           fval(hs),
      87           memset(1),
      88           copy1(hs),
      89           equal(1),
      90           arbs(hs);
      91
      92
      93$ stacked variables
      94
      95 .=zzyorg b $ reset counters for stack offsets
      96
      97      local(retpt);     $ return pointer
      98
      99      local(set1);     $ poiners to two sets.
     100      local(set2);
     101
     102      local(card);    $ cardinality of result
     103
     104      local(e);  $ pointer to current eb.
     105
     106      local(p1);   $ pointer to an element of set1
     107      local(p2);  $ pointer to element of set2
     108
     109      local(j);   $ loop index
     110
     111      local(prev);  $ pointer to last non-deleted eb
     112
     113      local(lsw1);      $ ls_words of two local maps
     114      local(lsw2);
     115
     116      local(share2);    $ flags sharing of an element of set2.
     117
     118      local(tup1);  $ pointers to tuples of remote maps
     119      local(tup2);
     120
     121      local(len1);    $ lengths of the tuples
     122      local(len2);
     123      local(min);  $ minimum of len1 and len2
     124
     125
     126/begin/                 $ begin execution
     127
     128      tstart = t;  $ save initial stack pointer
     129
     130 .=zzyorg a    $ reset counter for return labels
     131
     132      a1 = arg1;             $ make local copies of arguments.
     133      a2 = arg2;
     134
     135
     136
     137/entry/                $ recursive entry point
     138
     139      r_entry;   $ increment recursion stack
     140
     141      set1 = value_ a1;   $ get pointers to sets
     142      set2 = value_ a2;
     143
     144$ check that types match
     145
     146$ if the forms of the arguments are not similar, convert them to
     147$ set(*).
     148
     149      if ^ similar_repr(hform(set1), hform(set2)) then
     150          call convset(a1);   set1 = value_ a1;
     151          call convset(a2);   set2 = value_ a2;
     152      end if;
     153
     154$ branch on common type
     155
     156
     157      go to sc(htype(set1)) in h_uset to h_lrmap;
     158
     159
     160  /sc(h_uset)/                    $ standard set
     161
     162      intersect = inset(a1, a2);
     163      go to exit;
     164
     165
     166  /sc(h_umap)/                    $ standard map
     167
     168$ we iterate (! p1 _ domain set1), trying to locate a matching element
     169$ -p2- in the domain of set2. if one is found we take the intersection
     170$ of their images. if this is null we remove -p1- from the domain of
     171$ set1. otherwise we store the intersection as its new image.
     172$ set share bits in the domain of set1.
     173
     174$ when calling the delete routine, we do not automatically
     175$ rehash set1. instead we do it when we are done iterating
     176$ over it.
     177
     178      card = 0;    $ cardinality of result
     179
     180
     181      prev = 0;   $ pointer to last non-deleted eb
     182
     183      next_loop(p1, set1);      $ ( ! p1 _ domain. set1 )
     184
     185          call locate(pos, ebspec(p1), set2, no); $ see if its in domain
     186          p2 = pos;  $ save through recursion
     187
     188          if loc_found then   $ it is. see if images match
     189
     190              a1 = ebimag(p1);   $ get images
     191              a2 = ebimag(p2);
     192
     193              l_call(mult_im);  $ multiply images
     194
     195              if (share2) is_shared_ ebimag(p2) = yes;
     196
     197              if im_nelt = 0 then  $ drop element
     198                  call delete(set1, prev, p1, no);
     199
     200              else    $ store image and advance 'prev'
     201                  card = card+im_nelt;
     202                  ebimag(p1) = intersect;
     203
     204                  prev = p1;
     205              end if;
     206
     207          else      $ not found
     208              call delete(set1, prev, p1, no);
     209          end if;
     210
     211      end_next;
     212
     213      maycontract(set1);      $ rehash if necessary
     214
     215      nelt(set1) = card;
     216      if (ft_neltok(hform(set1))) is_neltok(set1) = yes;
     217
     218      is_hashok(set1) = no;
     219
     220
     221      build_spec(intersect, t_map, set1); $ build result
     222
     223      go to exit;
     224
     225
     226/sc(h_lset)/                  $ local subsets
     227
     228      intersect = inlset(a1, a2);
     229      go to exit;
     230
     231
     232
     233
     234  /sc(h_rset)/          $ remote subset
     235
     236      intersect = inrset(a1, a2);
     237      go to exit;
     238
     239
     240  /sc(h_lmap)/              $ local map
     241
     242$ we iterate over the eb-s of the base, taking the intersection
     243$ of the images.
     244
     245      lsw1 = ls_word(set1);     $ get ls_words.
     246      lsw2 = ls_word(set2);
     247
     248      card = 0;               $ cardinality of result
     249
     250      next_loop(e, set1);     $ iterate over base
     251          a1 = heap(e+lsw1);
     252          a2 = heap(e+lsw2);
     253
     254          l_call(mult_im);
     255$ if a2 has become part of the result, we must set its share bit in set2
     256          if (share2) is_shared(e+lsw2) = yes;
     257
     258          card = card+im_nelt;
     259          heap(e+lsw1) = intersect;
     260
     261      end_next;
     262
     263      set_nelt(set1, card);
     264
     265      is_hashok(set1) = no;
     266
     267
     268      build_spec(intersect, t_map, set1); $ build result
     269
     270      go to exit;
     271
     272
     273/sc(h_rmap)/                  $ remote map
     274
     275$ we iterate over the tuples for the two maps, taking the intersection
     276$ of corresponding elements. naturally we do this only for the length
     277$ of the shorter tuple.
     278
     279      card = 0;               $ cardinality of result
     280
     281      tup1 = set1 + hl_rmap;
     282      tup2 = set2 + hl_rmap;
     283
     284      len1 = maxindx(tup1);   $ get lengths
     285      len2 = maxindx(tup2);
     286
     287      min = len1;
     288      if (len1 > len2) min = len2;
     289
     290      j = 1;   $ loop index over tuple components
     291
     292      while j <= min;
     293          a1 = tcomp(tup1, j);
     294          a2 = tcomp(tup2, j);
     295
     296          l_call(mult_im);
     297$ if a2 has become part of the result, we must set its share bit in set2
     298          if (share2) is_shared_ tcomp(tup2, j) = yes;
     299
     300          card = card+im_nelt;
     301          tcomp(tup1, j) = intersect;
     302
     303          j = j+1;
     304      end while;
     305
     306
     307$ set remaining components of tup1 to match its template.
     308
     309      while j <= len1;
     310          tcomp(tup1, j) = tcomp(tup1, 0);
     311          j = j+1;
     312      end while;
     313
     314      set_nelt(set1, card);
     315
     316      is_hashok(set1) = no;
     317
     318      build_spec(intersect, t_map, set1); $ build result
     319
     320      go to exit;
     321
     322
     323
     324/sc(h_lpmap)/          $ local packed map
     325
     326      intersect = inlpm(a1, a2);
     327      go to exit;
     328
     329
     330/sc(h_limap)/             $ local untyped maps
     331
     332/sc(h_lrmap)/
     333
     334      intersect = inlum(a1, a2);
     335      go to exit;
     336
     337
     338
     339  /sc(h_rpmap)/          $ remote packed map
     340
     341      intersect = inrpm(a1, a2);
     342      go to exit;
     343
     344
     345
     346
     347  /sc(h_rrmap)/          $ remote real map
     348
     349  /sc(h_rimap)/          $ remote integer map
     350
     351      intersect = inrum(a1, a2);
     352      go to exit;
     353
     354
     355
     356
     357/mult_im/                 $ local routine to multiply images
     358
     359$ this local routine multiplies two map images -a1- and -a2-. it has
     360$ three outputs:
     361
     362$ intersect:   the intersection of the images
     363$ im_nelt:     the nelt of intersect.
     364$ share2:      indicates whether we must set the share bit of a2 in the
     365$              map it came from.
     366
     367$ non recursive cases are handled in line. if necessary, we jump to
     368$ the recursive entry point.
     369
     370      share2 = no;
     371
     372      if is_om_ a1 ! is_om_ a2 then $ return proper omega
     373          intersect = om_image(set1);
     374
     375      elseif is_multi_ a1 & ^ is_multi_ a2 then $ see if a2 _ a1
     376
     377          if memset(a2, a1) then  $ yes, return a2.
     378              intersect = a2;
     379              share2 = yes;
     380          else  $ no, return om.
     381              intersect = om_image(set1);
     382          end if;
     383
     384      elseif is_multi_ a2 & ^ is_multi_ a1 then  $ see if a1 _ a2
smfb  87
     385          if memset(a1, a2) then  $ yes, return a1
     387              intersect = a1;
     388          else    $ no, return om
     389              intersect = om_image(set1);
     390          end if;
     391
     392      elseif is_multi_ a1 & is_multi_ a2 then $ both multivalued
smfc  26          $ see if a1 and a2 are trivially equal (e.g. both null);  if
smfb  89          $ not, take intersection recursively.
     395          if eq(a1, a2) then
     396              intersect = a1;
     397          else
smfc  27              a1 = copy1(a1);  $ a1 cannot be used destructively
     399              go to entry;
     400          end if;
     401
     402      elseif eq(a1, a2) then  $ equal, so return a1
     403          intersect = a1;
     404
     405      elseif ne(a1, a2) then  $ unequal, return om
     406          intersect = om_image(set1);
     407
     408      elseif equal(a1, a2) then $ return a1
     409          intersect = a1;
     410
     411      else  $ return proper om
     412          intersect = om_image(set1);
     413      end if;
     414
     415$ get nelt of image.
     416      if is_multi_ intersect then
     417          ok_nelt(intersect);
     418          im_nelt = nelt(value_ intersect);
     419
     420      elseif is_om_ intersect then
     421          im_nelt = 0;
     422
     423      else
     424          im_nelt = 1;
     425      end if;
     426
     427
     428      go to rlab(retpt) in 1 to zzya;    $ return.
     429
     430
     431/exit/                     $ recursive return
     432
     433      r_exit;  $ pop recursion stack
     434
     435      if t ^= tstart then
     436
     437          im_nelt = nelt(value_ intersect);  $ find nelt
     438          is_multi_ intersect = yes;
     439
     440$ if we are taking the intersection of two mmaps, we replace a null
     441$ result with the nullset in the template block. otherwise we
     442$ we remove singleton and null sets
     443          if is_mmap(set1) then
     444              if (im_nelt = 0) intersect = om_image(set1);
     445          else
     446              if (im_nelt <= 1) intersect = arbs(intersect);
     447          end if;
     448
     449          go to rlab(retpt) in 1 to zzya;
     450
     451      else                      $ actual return
     452          return;
     453      end if;
     454
     455
     456
     457$ drop local variables
     458
     459      macdrop8(retpt, set1, set2, card, p1, p2, lsw1, lsw2)
     460      macdrop8(share2, tup1, tup2, len1, len2, min, j, prev)
     461      macdrop(e)
     462
     463      end fnct intersect;
       1 .=member inset
       2      fnct inset(arg1, arg2);
       3
       4
       5      size inset(hs);      $ specifier returned
       6
       7      size arg1(hs),     $ specifiers for two sets
       8           arg2(hs);
       9
      10
      11      size set1(ps),    $ pointers to two sets
      12           set2(ps);
      13
      14      size p1(ps),    $ pointers to current ebs of two sets
      15           p2(ps);
      16
      17      size prev(ps); $ pointer to last non-deleted eb
      18
      19
      20      set1 = value_ arg1;  $ get pointers to sets
      21      set2 = value_ arg2;
      22
      23$ we iterate (! p1 _ set1). if no matching element can be found in set
      24$ we delete p1 from set1 and subtract its hash from that of set1.
      25
      26$ when we call the delete routine, we do not automatically rehash
      27$ set1. instead we do it when we are done iterating over it.
      28
      29
      30      prev = 0;  $ pointer to last non-deleted eb
      31
      32      next_loop(p1, set1);      $  (! p1 _   set1 )
      33
      34          call locate(p2, ebspec(p1), set2, no);
      35
      36          if ^ loc_found then
      37              down_hash(set1, loc_hash);
      38              call delete(set1, prev, p1, no);
      39
      40          else   $ advance 'prev'
      41              prev = p1;
      42          end if;
      43
      44      end_next;
      45
      46      maycontract(set1);  $ rehash if necessary
      47
      48
      49      set_nelt(set1, neb(hashtb(set1)));
      50
      51      build_spec(inset, t_set, set1);
      52
      53
      54      end fnct inset;
       1 .=member inlset
       2      fnct inlset(a1, a2);  $ local subset intersection
       3
       4
       5      size inlset(hs);      $ specifier returned
       6
       7      size a1(hs),   $ specifiers for two sets
       8           a2(hs);
       9
      10      size set1(ps),  $ pointers to two sets
      11           set2(ps);
      12
      13      size lsw1(ps),    $ their ls_words
      14           lsw2(ps),
      15           lsb1(ps),    $ their ls_bits
      16           lsb2(ps);
      17
      18      size bit1(1),  $ current bit of set1
      19           bit2(1),  $ bit of set2
      20           bit(1);  $ bit of result
      21
      22      size card(ps),  $ nelt of result
      23           hashc(ps); $ hash of result
      24
      25      size e(ps);     $ pointer to current eb of base.
      26
      27
      28      set1 = value_ a1;  $ get pointers to sets
      29      set2 = value_ a2;
      30
      31$ we iterate over the common base, and-ing the bits corresponding
      32$ to the two sets. we also calculate the nelt and hash of the set as
      33$ we go.
      34
      35      lsw1 = ls_word(set1);    $ get ls_words and ls_bits.
      36      lsb1 = ls_bit(set1);
      37
      38      lsw2 = ls_word(set2);
      39      lsb2 = ls_bit(set2);
      40
      41      card = 0;           $ cardinality of result
      42      hashc = hc_set;     $ hash code of null set
      43
      44      next_loop(e, set1);        $ iterate over base
      45
      46          bit1 = .f. lsb1, 1, heap(e+lsw1);
      47          bit2 = .f. lsb2, 1, heap(e+lsw2);
      48
      49          bit = (bit1 & bit2);
      50
      51          card = card+bit;
      52          if (bit) hashc = hashc + ebhash(e); $ add hash from base
      53
      54          .f. lsb1, 1, heap(e+lsw1) = bit;
      55
      56      end_next;
      57
      58      set_nelt(set1, card);
      59      set_hash(set1, hashc);
      60
      61      build_spec(inlset, t_set, set1);
      62
      63
      64      end fnct inlset;
       1 .=member inrset
       2      fnct inrset(arg1, arg2);  $ remote subset intersection
       3
       4
       5      size inrset(hs);   $ specifier returned
       6
       7      size arg1(hs),   $ specifiers for two sets
       8           arg2(hs);
       9
      10      size set1(ps),   $ pointers to two sets
      11           set2(ps);
      12
      13      size p1(ps),   $ pointers to their bit strings
      14           p2(ps);
      15
      16      size len1(ps),   $ kengths of bit strings
      17           len2(ps),
      18           min(ps);  $ minimum of len1 and len2.
      19
      20      size j(ps);             $ loop index
      21      size word(hs);          $ current word of bit string
      22
      23
      24      set1 = value_ arg1;  $ get pointers to sets
      25      set2 = value_ arg2;
      26
      27
      28$ we and together the bit stringds for the two subsets. natuarally
      29$ we need do this only for the length of the shorter string.
      30
      31
      32$ since we are not looking at set elements one at a time, we do not
      33$ calculate the hash code of the set.
      34
      35      len1 = rswords(set1);   $ get their lengths.
      36      len2 = rswords(set2);
      37
      38      min = len1;
      39      if (len1 > len2) min = len2;
      40
      41
      42                    $ take intersect over length of shorter string
      43      do j = 1 to min;
      44          word = (rsword(set1, j) & rsword(set2, j));
      45          rsword(set1, j) = word;
      46      end do;
      47
      48$ zero out remaining words of set1
      49
      50      do j = min+1 to len1;
      51          rsword(set1, j) = 0;
      52      end do;
      53
      54      is_neltok(set1) = no;
      55      is_hashok(set1) = no;
      56
      57      build_spec(inrset, t_set, set1);
      58
      59
      60      end fnct inrset;
       1 .=member inlpm
       2      fnct inlpm(a1, a2);  $ local packed map intersection
       3
       4$ this routine finds the intersection of two local packed maps with
       5$ the same repr. since they have the same repr, the two maps have
       6$ the same ls_bits and ls_vect.
       7
       8
       9      size inlpm(hs);    $ specifier returned
      10
      11      size a1(hs),   $ specifiers for two sets
      12           a2(hs);
      13
      14      size set1(ps),    $ pointers to the sets
      15           set2(ps);
      16
      17      size lsw1(ps),      $ their ls_words
      18           lsw2(ps),
      19           lsb1(ps),    $ their ls_bits
      20           lsb2(ps);
      21
      22      size bits(ps),    $ number of bits/value
      23           card(ps),     $ cardinality of result
      24           e(ps);   $ pointer to current eb of base
      25
      26      size v1(hs),    $ current packed values
      27           v2(hs);
      28
      29
      30      set1 = value_ a1;  $ get pointers to sets
      31      set2 = value_ a2;
      32
      33      lsw1 = ls_word(set1);  $ get ls_word_ and ls_bit_ values.
      34      lsw2 = ls_word(set2)+1;
      35
      36      lsb1 = ls_bit(set1);
      37      lsb2 = ls_bit(set2);
      38
      39      bits = ls_bits(set1);  $ bits per entry
      40
      41      card = 0;        $ cardinality of result
      42
      43      next_loop(e, set1);
      44          v1 = .f. lsb1, bits, heap(e+lsw1);  $ get packed valu
      45          v2 = .f. lsb2, bits, heap(e+lsw2);
      46
      47          if v1 = 0 then   $ intersection is null
      48              cont;
      49
      50          elseif v2 = 0 then  $ intersection is again null
      51              .f. lsb1, bits, heap(e+lsw1) = 0;
      52
      53          elseif v1 = v2 then  $ intersection is v1, which is already in
      54              card = card+1;
      55
      56          else   $ images are unequal, so result is om.
      57              .f. lsb1, bits, heap(e+lsw1) = 0;
      58
      59          end if;
      60      end_next;
      61
      62      set_nelt(set1, card);
      63
      64      is_hashok(set1) = no;
      65
      66      build_spec(inlpm, t_map, set1);
      67
      68
      69      end fnct inlpm;
       1 .=member inlum
       2      fnct inlum(arg1, arg2);
       3
       4$ this routine performs intersection on untyped local maps.
       5
       6
       7      size inlum(hs);    $ specifier returned
       8
       9      size arg1(hs),    $ specifiers for two sets
      10           arg2(hs);
      11
      12      size a1(hs), $ tuple components
      13           a2(hs);
      14
      15      size set1(ps),   $ pointers to two sets
      16           set2(ps);
      17
      18      size om_val(hs),     $ proper om value for components
      19           card(ps),     $ cardinality of result
      20           e(ps);   $ pointer to current eb of base
      21
      22      size lsw1(ps),   $ ls_words of the arguments
      23           lsw2(ps);
      24
      25
      26      set1 = value_ a1;  $ get pointers to sets
      27      set2 = value_ a2;
      28
      29      lsw1 = ls_word(set1);  $ get ls_words
      30      lsw2 = ls_word(set2);
      31
      32      card = 0;  $ cardinality of result
      33
      34$ get om image value as it appears in map
      35      om_val = heap(template(set1)+lsw1);
      36
      37                   $ loop over base
      38      next_loop(e, set1);
      39
      40          a1 = heap(e+lsw1);
      41          a2 = heap(e+lsw2);
      42
      43          if a1 = a2 then  $ result is a1. adjust nelt
      44              if (^ a1 ^= om_val) card = card+1;
      45
      46          else    $ result is om.
      47              heap(e+lsw1) = om_val;
      48          end if;
      49      end_next;
      50
      51      set_nelt(set1, card);
      52
      53      is_hashok(set1) = no;
      54
      55      build_spec(inlum, t_map, set1);
      56
      57
      58      end fnct inlum;
       1 .=member inrpm
       2      fnct inrpm(a1, a2);  $ remote packed map intersection
       3
       4$ this routine handles the intersection of two remote packed maps
       5$ with the same repr. the tuples for the two sets have the same
       6$ ptbits, ptvect, etc.
       7
       8
       9      size inrpm(hs);     $ specifier returned
      10
      11      size a1(hs),     $ specifiers for two sets
      12           a2(hs);
      13
      14      size set1(ps),    $ pointers to two sets
      15           set2(ps),
      16           p1(ps),    $ pointers to their tuples
      17           p2(ps);
      18
      19      size len1(ps),    $ lengths of the two tuples
      20           len2(ps),
      21           min(ps),   $ minimum of len1 and len2.
      22           v1(ps),     $ their packed values
      23           v2(ps);
      24
      25       size bits(ps),    $ bits/packed value
      26           card(ps),    $ cardinality of resut
      27           j(ps),    $ loop index over words of tuple
      28           org(ps);    $ loop index over bit origin in word
      29
      30
      31      set1 = value_ a1;  $ get pointers to sets
      32      set2 = value_ a2;
      33$ we use a double loop over the tuples, one for sucessive words and
      34$ one for successive elements in a word.
      35
      36      card = 0;         $ cardinality of result
      37
      38      p1 = set1 + hl_rpmap;
      39      p2 = set2 + hl_rpmap;
      40
      41      len1 = maxindx(p1);  $ get lengths
      42      len2 = maxindx(p2);
      43
      44      min = len1;
      45      if (len1 > len2) min = len2;
      46
      47      bits = ptbits(p1);  $ bits per entry
      48
      49
      50      do j = hl_ptuple to packoffs(p1, min);
      51
      52          do org = 1 to bpos_max by bits;
      53
      54              v1 = .f. org, bits, heap(p1+j);
      55              v2 = .f. org, bits, heap(p2+j);
      56
      57              if v1 = v2 then  $ result is v1. adjust card
      58                  if (v1 ^= 0) card = card+1;
      59              else             $ result is om.
      60                  .f. org, bits, heap(p1+j) = 0;
      61              end if;
      62
      63          end do;
      64      end do;
      65
      66$ zero out remaining words of set1
      67
      68      do j = packoffs(p1, min)+1 to packoffs(p1, len1);
      69          heap(p1+j) = 0;
      70          end do;
      71
      72      set_nelt(set1, card);
      73
      74      is_hashok(set1) = no;
      75
      76      build_spec(inrpm, t_map, set1);
      77
      78
      79      end fnct inrpm;
       1 .=member inrum
       2      fnct inrum(arg1, arg2);
       3
       4$ this routine performs intersection on untyped remote maps.
       5
       6
       7      size inrum(hs);      $ specifier returned
       8
       9      size arg1(hs),      $ specifiers for two sets
      10           arg2(hs);
      11
      12      size set1(ps),     $ pointers to the sets
      13           set2(ps),
      14           tup1(ps),      $ pointers to their tuples
      15           tup2(ps);
      16
      17      size len1(ps),    $ length of the tuples
      18           len2(ps),
      19           min(ps); $ minimum of above
      20
      21      size card(ps),     $ cardinality of result
      22           om_val(hs),  $ untyped om value
      23           j(ps);    $ loop index over tuple components
      24
      25      size a1(hs),    $ tuple components
      26           a2(hs);
      27
      28
      29      set1 = value_ a1;  $ get pointers to sets
      30      set2 = value_ a2;
      31        $ set om_val to type_ of om value_ which
      32                          $ might appear in map.
      33      card = 0;         $ cardinality of result
      34
      35      tup1 = set1+1;      $ get pointers to tuples
      36      tup2 = set2+1;
      37
      38      len1 = maxindx(tup1);  $ get thier lengths.
      39      len2 = maxindx(tup2);
      40
      41                  $ make set1 the smaller tuple
      42      min = len1;
      43      if (len1 > len2) min = len2;
      44
      45$ get om image as it appears in tuple
      46      om_val = tcomp(tup1, 0);
      47
      48      do j = 1 to min;
      49
      50          a1 = tcomp(tup1, j);
      51          a2 = tcomp(tup2, j);
      52
      53          if a1 ^= a2 ! a1 = om_val ! a2 = om_val then
      54              tcomp(tup1, j) = om_val;
      55
      56          else
      57              tcomp(tup1, j) = a1;
      58              card = card+1;
      59
      60          end if;
      61      end do;
      62
      63$ set remaining words of set1 to om_val.
      64
      65      do j = min+1 to len1;
      66          tcomp(tup1, j) = om_val;
      67      end do;
      68
      69
      70
      71      set_nelt(set1, card);
      72
      73      is_hashok(set1) = no;
      74
      75      build_spec(inrum, t_map, set1);
      76
      77
      78      end fnct inrum;
       1 .=member setdiff
       2      fnct setdiff(arg1, arg2);
       3
       4
       5$ union, intersection, and set difference are variations of the same
       6$ algorithm. each of these primitives is relatively simple when
       7$ applied to sets, subsets, packed maps, and untyped maps, but quite
       8$ complex when applied to multi valued maps. for this reason operations
       9$ on each of the simpler types are done from seperate routines which
      10$ can be called from the general union (etc) routine or directly from
      11$ the code. the general routines contain code to handle general maps
      12$ plus code to call the lower level routines.
      13
      14$ the set difference routine begins with a branch on type. the code
      15$ for those types which may require recursion is contained in line;
      16$ the code for other types is found in seperate routines.
      17
      18$ subtracting two maps requires the following steps:
      19
      20$ 1. find some matching element x in the domain of set1 and set2.
      21$    set a1 = set1(x) and a2 = set2(x). call the local routine
      22$    diff_im.
      23
      24$ 2. if either or both of its arguments are single valued, diff_im
      25$    will set 'setdiff' to their difference. in this
      26$    process either a1 or a2 may become part of the result. for
      27$    a1 this is no problem, since set1 is being used destructively
      28$    anyway. however if a2 is included in the result, we must
      29$    make a note to set its share bit in set2. this is done by
      30$    setting the flag share2 = yes.
      31
      32$ 3. if both a1 and a2 are multivalued, we jump to the take their
      33$   difference recursively. we do this by jumping to the recursive
      34$   entry point. after the recursive call, we will return directly to
      35$   diff_im-s caller.
      36
      37$ 4. on return from diff_im, we set set1(x) = setdiff. if necessary,
      38$    we also set the share bit of set2(x).
      39
      40$ setdiff is called in one of two contexts:
      41
      42$ 1. the returned value, arg1, and arg2 have all been declared
      43$    to be of some common mode m.
      44
      45$ 2. the returned value, arg1, and arg2 are undeclared. their
      46$    are two possibilities here:
      47
      48$    a. arg1 and arg2 have some common mode m, so we return a
      49$       value of mode m.
      50
      51$    b. arg1 and arg2 have different modes. we convert both
      52$       to unbased set(*) and return a result of unbased set(*).
      53
      54$ in both cases we assume that a1 can be used destructively.
      55
      56$ setdiff computes the nelt of its result at every recursive level, an
      57$ trusts the nelt field to be valid after a recursive return, regardless
      58$ of the setting of is_neltok.
      59
      60      size setdiff(hs);       $ specifier returned
      61
      62      size arg1(hs);          $ specifier for first input
      63      size arg2(hs);          $ specifier for second argument
      64
      65      size a1(hs),          $ local copies of arguments, used for
      66           a2(hs);          $ recursion.
      67
      68
      69      size tstart(ps);  $ pointer to recursion stack at start of routin
      70
      71      size im_nelt(ps);  $ nelt of map image. this is an auxilliary
      72                            $ output of the routine.
      73
      74      size pos(ps);  $ value return parameter of locate
      75
      76      size difset(hs),  $ functions called
      77           diflset(hs),
      78           difrset(hs),
      79           diflpm(hs),
      80           diflum(hs),
      81           difrpm(hs),
      82           difrum(hs),
      83           less(hs),
      84           fval(hs),
      85           memset(1),
      86           copy1(hs),
      87           equal(1),
      88           arb1(hs),
      89           arbs(hs);
      90
      91$ stacked variables
      92
      93 .=zzyorg b $ reset counters for stack offsets
      94
      95      local(retpt);     $ return pointer
      96
      97      local(set1);     $ poiners to two sets.
      98      local(set2);
      99
     100      local(card);    $ cardinality of result
     101
     102      local(p1);   $ pointer to an element of set1
     103      local(p2);    $ pointer to an element of set2
     104
     105      local(j);  $ loop index over tuple components
     106
     107      local(lsw1);      $ ls_words of two local maps
     108      local(lsw2);
     109
     110      local(share2);    $ flags sharing of an element of set2.
     111
     112      local(tup1);  $ pointers to tuples of remote maps
     113      local(tup2);
     114
     115      local(len1);    $ lengths of the tuples
     116      local(len2);
     117
     118      local(prev);  $ pointer to last non-deleted eb
     119
     120      local(min);   $ length of shorter tuple
     121
     122      local(plima);  $ limits for p1 over remote maps
     123      local(plimb);
     124
     125
     126
     127/begin/
     128
     129                       $ begin execution
     130
     131      tstart = t;  $ save initial stack pointer
     132
     133 .=zzyorg a    $ reset counter for return labels
     134
     135      a1 = arg1;            $ copy arguments
     136      a2 = arg2;
     137
     138
     139
     140/entry/                $ recursive entry point
     141
     142
     143      r_entry;    $ increment recursion stack
     144
     145      set1 = value_ a1;      $ get pointers to set headers
     146      set2 = value_ a2;
     147
     148$ check that types match
     149
     150$ if the forms of the arguments are not similar, convert them to
     151$ set(*).
     152
     153      if ^ similar_repr(hform(set1), hform(set2)) then
     154          call convset(a1);   set1 = value_ a1;
     155          call convset(a2);   set2 = value_ a2;
     156      end if;
     157
     158
     159      go to sc(htype(set1)) in h_uset to h_lrmap;
     160
     161
     162  /sc(h_uset)/                    $ standard set
     163
     164      setdiff = difset(a1, a2);
     165      go to exit;
     166
     167
     168  /sc(h_umap)/                    $ standard map
     169
     170$ we iterate (! p1 _   domain set1), trying to find a matching element
     171$ -p2- in the domain of set2. if one is found, we take the difference
     172$ of their images. if this is null, we delete -p1- from the domain of
     173$ set1. otherwise we set its image to the difference of the images.
     174
     175$ when we call the delete routine, we do not automatically rehash
     176$ set1. instead we rehash it when we are done iterating over it.
     177
     178      card = 0;               $ cardinality of result
     179      prev = 0;               $ pointer to last non-deleted eb
     180
     181      next_loop(p1, set1);    $ (forall p1 in set1)
     182
     183          call locate(pos, ebspec(p1), set2, no);
     184          p2 = pos;  $ save through recursion
     185
     186          if loc_found then
     187                 $ p1 is in both domains. get difference of images.
     188              a1 = ebimag(p1);   $ get images
     189              a2 = ebimag(p2);
     190
     191              l_call(diff_im);     $ take difference of images
     192
     193              if im_nelt = 0 then  $ delete p1 from domain
     194                  call delete(set1, prev, p1, no);
     195
     196              else  $ store image, add nelt, and advance 'prev'
     197                  ebimag(p1) = setdiff;
     198                  card = card+im_nelt;
     199
     200                  prev = p1;
     201              end if;
     202
     203          else      $ get image of p1, add its nelt, and advance 'prev'
     204              a1 = ebimag(p1);
     205
     206              if is_multi_ a1 then
     207                  ok_nelt(a1);
     208                  card = card + nelt(value_ a1);
     209              else
     210                  card = card + 1;
     211              end if;
     212
     213              prev = p1;
     214
     215          end if;
     216
     217      end_next;
     218
     219      maycontract(set1);  $ rehash if necessary
     220
     221      set_nelt(set1, card);
     222
     223      is_hashok(set1) = no;
     224
     225
     226      build_spec(setdiff, t_map, set1); $ build result
     227
     228      go to exit;
     229
     230
     231 /sc(h_lset)/                 $ local subsets
     232
     233      setdiff = diflset(a1, a2);
     234      go to exit;
     235
     236
     237/sc(h_rset)/                  $ remote subset
     238
     239      setdiff = difrset(a1, a2);
     240      go to exit;
     241
     242
     243  /sc(h_lmap)/              $ local map
     244
     245$ iterate over the common base, taking the difference of the
     246$ difference of the corresponding words in each eb.
     247
     248      lsw1 = ls_word(set1);     $ get ls_words.
     249      lsw2 = ls_word(set2);
     250
     251      card = 0;       $ cardinality of result
     252
     253      next_loop(p1, set1);
     254
     255                 $ form difference of images of e.
     256          a1 = heap(p1+lsw1);
     257          a2 = heap(p1+lsw2);
     258
     259          l_call(diff_im);    $ take difference of images
     260
     261          card = card+im_nelt;
     262          heap(p1+lsw1) = setdiff;
     263
     264      end_next;
     265
     266      set_nelt(set1, card);
     267
     268      is_hashok(set1) = no;
     269
     270
     271      build_spec(setdiff, t_map, set1);  $ build result
     272
     273      go to exit;
     274
     275
     276
     277  /sc(h_rmap)/               $ remote map
     278
     279$ iterate over the two tuples for the length of the shorter, taking
     280
     281$ nelt of the result the result to include the remaining elements of
     282$ set1.
     283
     284$ we have two while loops, the first to take the difference of elements,
     285$ and the second to adjust the nelt of the result
     286                             $ the logic here is similar to remote s
     287                             $ subsets.
     288
     289      card = 0;                     $ cardinality of result
     290
     291      tup1 = set1 + hl_rmap;
     292      tup2 = set2 + hl_rmap;
     293
     294      len1 = maxindx(tup1);      $ get lengths.
     295      len2 = maxindx(tup2);
     296
     297      min = len1;          $ find minimum length
     298      if (min > len2) min = len2;
     299
     300
     301      j = 1;  $ loop over tuple components
     302
     303      while j <= min;
     304          a1 = tcomp(tup1, j);
     305          a2 = tcomp(tup2, j);
     306
     307          l_call(diff_im);  $ take difference of images.
     308
     309          card = card+im_nelt;
     310          tcomp(tup1, j) = setdiff;
     311
     312          j = j+1;
     313      end while;
     314
     315
     316                                $ add remaining words of set1.
     317
     318      while j <= len1;
     319          a1 = tcomp(tup1, j);
     320          j = j+1;
     321
     322          if is_multi_ a1 then
     323              ok_nelt(a1);
     324              card = card + nelt(value_ a1);
     325
     326          else
     327              if (^ is_om_ a1) card = card+1;
     328          end if;
     329
     330      end while;
     331
     332      set_nelt(set1, card);
     333
     334      is_hashok(set1) = no;
     335
     336
     337      build_spec(setdiff, t_map, set1); $ build result
     338
     339      go to exit;
     340
     341
     342
     343  /sc(h_lpmap)/          $ local packed map
     344
     345      setdiff = diflpm(a1, a2);
     346      go to exit;
     347
     348
     349/sc(h_limap)/    $ local untyped maps
     350
     351/sc(h_lrmap)/
     352
     353      setdiff = diflum(a1, a2);
     354      go to exit;
     355
     356
     357
     358/sc(h_rpmap)/          $ remote packed map
     359
     360      setdiff = difrpm(a1, a2);
     361      go to exit;
     362
     363
     364
     365
     366/sc(h_rrmap)/          $ remote untyped maps
     367
     368/sc(h_rimap)/
     369
     370      setdiff = difrum(a1, a2);
     371      go to exit;
     372
     373
     374
     375/diff_im/                 $ local routine to subtract images
     376
     377$ this local routine takes the difference of two map images a1 and a2.
     378$ its outputs are:
     379
     380$ im_nelt:   nelt of the result
     381$ share2:    indicates that we should set the share bit of a2 in the
     382$            map it came from.
     383
     384$ nonrecursive cases are handled below. if recursion is necessary,
     385$ we jump to the recursive entry point.
     386
     387
     388      share2 = no;
     389
     390      if is_om_ a1 ! is_om_ a2 then   $ return a1
     391          setdiff = a1;
     392
     393      elseif is_multi_ a1 & ^ is_multi_ a2 then  $ return a1 less a2
     394
     395          maycopy(a1);  $ copy if necessary
     396          setdiff = less(a1, a2);
     397          is_multi_ setdiff = yes;
     398
     399          if (^ is_mmap(set1)) setdiff = arb1(setdiff);
     400
     401      elseif is_multi_ a2 & ^ is_multi_ a1 then  $ see if a1 _ a2
     402
     403          if memset(a1, a2) then  $ it is, so return om.
     404              setdiff = om_image(set1);
     405          else  $ return a1
     406              setdiff = a1;
     407          end if;
     408
     409      elseif is_multi_ a1 & is_multi_ a2 then  $ both multivalued.
     410                   $ see if they are trivially equal(i.e. both null).
     411               $ if not, take difference recursively
     412          if eq(a1, a2) then
     413              setdiff = om_image(set1);
     414          else
     415              maycopy(a1);
     416              go to entry;
     417          end if;
     418
     419      elseif eq(a1, a2) then  $ return om or null range set
     420          setdiff = om_image(set1);
     421
     422      elseif ne(a1, a2) then  $ unequal, return a1
     423          setdiff = a1;
     424
     425      elseif equal(a1, a2) then$ equal, return om. or null range set
     426          setdiff = om_image(set1);
     427
     428      else  $ unequal, return a1
     429          setdiff = a1;
     430      end if;
     431
     432$ get nelt of image
     433      if is_multi_ setdiff then
     434          ok_nelt(setdiff);
     435          im_nelt = nelt(value_ setdiff);
     436
     437      elseif is_om_ setdiff then
     438          im_nelt = 0;
     439
     440      else
     441          im_nelt = 1;
     442      end if;
     443
     444
     445      go to rlab(retpt) in 1 to zzya;    $ return.
     446
     447
     448/exit/                     $ recursive return
     449
     450      r_exit;   $ pop recursion stack
     451
     452      if t ^= tstart then
     453                         $ recursive return. do extra bookkeeping
     454
     455          im_nelt = nelt(value_ setdiff);  $ hold onto nelt
     456          is_multi_ setdiff = yes;
     457
     458$ if we are taking the difference of two mmaps, we replace null results
     459$ with the nullset in the template. otherwise we get rid of singleton
     460$ and null range sets.
     461          if is_mmap(set1) then
     462              if (im_nelt = 0) setdiff = om_image(set1);
     463          else
     464              if (im_nelt <= 1) setdiff = arbs(setdiff);
     465          end if;
     466
     467
     468          go to rlab(retpt) in 1 to zzya;
     469
     470      else                      $ actual return
     471          return;
     472      end if;
     473
     474
     475
     476$ drop local variables
     477
     478      macdrop8(retpt, set1, set2, card, p1, p2, lsw1, lsw2)
     479      macdrop8(share2, tup1, tup2, len1, len2, prev, min, j)
     480
     481      end fnct setdiff;
       1 .=member difset
       2      fnct difset(arg1, arg2);  $ standard set difference
       3
       4
       5      size difset(hs);      $ specifier returned
       6
       7      size arg1(hs),     $ specifiers for two sets
       8           arg2(hs);
       9
      10
      11      size set1(ps),    $ pointers to two sets
      12           set2(ps);
      13
      14      size p1(ps),    $ pointers to current ebs of two sets
      15           p2(ps);
      16
      17      size prev(ps);  $ pointer to last non-deleted eb
      18
      19
      20      set1 = value_ arg1;  $ get pointers to sets
      21      set2 = value_ arg2;
      22
      23
      24$ we iterate over set1, deleting elements if a corresponding element
      25$ can be found in set2. we adjust the hash of set1 as we delete elements
      26
      27$ rather than rehashing set1 as we delete elements, we do it when
      28$ we are done iterating over it.
      29
      30      prev = 0;  $ pointer to last non-deleted eb
      31
      32      next_loop(p1, set1);      $  (! _  e  set1 )
      33
      34          call locate(p2, ebspec(p1), set2, no);
      35
      36          if loc_found then  $ delete element and adjust hash
      37              down_hash(set1, loc_hash);
      38              call delete(set1,prev, p1, no);
      39
      40          else   $ advance 'prev'
      41              prev = p1;
      42          end if;
      43
      44      end_next;
      45
      46      maycontract(set1);  $ rehash if necessary
      47
      48      set_nelt(set1, neb(hashtb(set1)));
      49
      50      build_spec(difset, t_set, set1);
      51
      52      return;
      53
      54      end fnct difset;
       1 .=member diflset
       2      fnct diflset(arg1, arg2);  $ local subset difference
       3
       4
       5      size diflset(hs);      $ specifier returned
       6
       7      size arg1(hs),   $ specifiers for two sets
       8           arg2(hs);
       9
      10      size set1(ps),  $ pointers to two sets
      11           set2(ps);
      12
      13      size lsw1(ps),    $ their ls_words
      14           lsw2(ps),
      15           lsb1(ps),    $ their ls_bits
      16           lsb2(ps);
      17
      18      size bit1(1),  $ current bit of set1
      19           bit2(1),  $ bit of set2
      20           bit(1);  $ bit of result
      21
      22      size card(ps),  $ nelt of result
      23           hashc(ps);   $ hash of result
      24      size e(ps);     $ pointer to current eb of base.
      25
      26
      27      set1 = value_ arg1;  $ get pointers to sets
      28      set2 = value_ arg2;
      29
      30$ iterate over the common base, taking the difference of the
      31$ corresponding bits in each eb.
      32
      33$ we calculate the nelt and hash of the set as we go.
      34
      35      lsw1 = ls_word(set1);    $ get ls_words and ls_bits.
      36      lsb1 = ls_bit(set1);
      37
      38      lsw2 = ls_word(set2);
      39      lsb2 = ls_bit(set2);
      40
      41      card = 0;           $ cardinality of result
      42      hashc = hc_set;   $ hash of null set
      43
      44
      45      next_loop(e, set1);        $ iterate over base
      46
      47          bit1 = .f. lsb1, 1, heap(e+lsw1);
      48          bit2 = .f. lsb2, 1, heap(e+lsw2);
      49
      50          bit = (bit1 & ^bit2);
      51
      52          card = card+bit;
      53          if (bit) hashc = hashc + ebhash(e); $ add hash from base
      54
      55
      56          .f. lsb1, 1, heap(e+lsw1) = bit;
      57
      58      end_next;
      59
      60
      61
      62      set_nelt(set1, card);
      63      set_hash(set1, hashc);
      64
      65      build_spec(diflset, t_set, set1);
      66
      67      return;
      68
      69      end fnct diflset;
       1 .=member difrset
       2      fnct difrset(arg1, arg2);  $ remote subset difference
       3
       4
       5      size difrset(hs);   $ specifier returned
       6
       7      size arg1(hs),   $ specifiers for two sets
       8           arg2(hs);
       9
      10      size set1(ps),   $ pointers to two sets
      11           set2(ps);
      12
      13      size p1(ps),   $ pointers to their bit strings
      14           p2(ps);
      15
      16      size len1(ps),   $ kengths of bit strings
      17           len2(ps),
      18           min(ps); $ minimum of len1 and len2.
      19
      20      size j(ps);             $ loop index
      21      size word(hs);          $ current word of bit string
      22
      23
      24      set1 = value_ arg1;
      25      set2 = value_ arg2;
      26
      27$ iterate over the two bit strings for the length of the shorter,
      28$ taking the boolean difference of each word. then add the remaining
      29$ words of the bit string for set1 (if any) into the nelt of the result
      30$ since we are not looking at individual elements, we do not calculate
      31$ the hash of the set.
      32
      33      len1 = rswords(set1);
      34      len2 = rswords(set2);
      35
      36      min = len1;      $ find shorter length
      37      if (min > len2) min = len2;
      38
      39      do j = 1 to min;
      40          word = rsword(set1, j) & ^ rsword(set2, j);
      41          rsword(set1, j) = word;
      42      end do;
      43                            $ add remaining words of set1
      44      is_neltok(set1) = no;
      45      is_hashok(set1) = no;
      46
      47      build_spec(difrset, t_set, set1);
      48
      49
      50      end fnct difrset;
       1 .=member diflpm
       2      fnct diflpm(a1, a2);  $ local packed map difference
       3
       4
       5      size diflpm(hs);    $ specifier returned
       6
       7      size a1(hs),   $ specifiers for two sets
       8           a2(hs);
       9
      10      size set1(ps),    $ pointers to the sets
      11           set2(ps);
      12
      13      size ebw1(ps),      $ their ls_words
      14           ebw2(ps),
      15           ebb1(ps),    $ their ls_bits
      16           ebb2(ps);
      17
      18      size bits(ps),    $ number of bits/value
      19           card(ps),     $ cardinality of result
      20            e(ps);   $ pointer to current eb of base
      21
      22      size v1(hs),    $ current packed values
      23           v2(hs);
      24
      25
      26      set1 = value_ a1;  $ get pointers to sets
      27      set2 = value_ a2;
      28
      29$ iterate over base taking difference of elements.
      30
      31      ebw1 = ls_word(set1);  $ get ls_word_ and ls_bit_ values.
      32      ebw2 = ls_word(set2);
      33
      34      ebb1 = ls_bit(set1);
      35      ebb2 = ls_bit(set2);
      36
      37      bits = ls_bits(set1);  $ bits per entry
      38
      39      card = 0;        $ cardinality of result
      40
      41      next_loop(e, set1);
      42
      43          v1 = .f. ebb1, bits, heap(e+ebw1);  $ get packed valu
      44          v2 = .f. ebb2, bits, heap(e+ebw2);
      45
      46          if v1 = 0 then   $ difference is null
      47              cont;
      48
      49          elseif v1 = v2 then  $ difference is null
      50              .f. ebb1, bits, heap(e+ebw1) = 0;
      51
      52          else       $ difference is v1
      53              card = card+1;
      54
      55          end if;
      56      end_next;
      57
      58
      59      set_nelt(set1, card);
      60
      61      is_hashok(set1) = no;
      62
      63      build_spec(diflpm, t_map, set1);
      64
      65
      66      end fnct diflpm;
       1 .=member diflum
       2      fnct diflum(arg1, arg2);
       3
       4
       5      size diflum(hs);    $ specifier returned
       6
       7      size arg1(hs),    $ specifiers for two sets
       8           arg2(hs);
       9
      10      size a1(hs),  $ tuple components
      11           a2(hs);
      12
      13      size set1(ps),   $ pointers to two sets
      14           set2(ps);
      15
      16      size om_val(hs),     $ proper om value for components
      17           card(ps),     $ cardinality of result
      18           e(ps);   $ pointer to current eb of base
      19
      20      size ebw1(ps),   $ ls_words of the arguments
      21           ebw2(ps);
      22
      23
      24      set1 = value_ a1;  $ get pointers to sets
      25      set2 = value_ a2;
      26
      27         $ set -om_val- to om value_ which might
      28                           $ appear in map.
      29
      30
      31      ebw1 = ls_word(set1);  $ get ls_words
      32      ebw2 = ls_word(set2);
      33
      34      card = 0;  $ cardinality of result
      35
      36$ get om image as it appears in map
      37      om_val = heap(template(set1)+ebw1);
      38
      39                   $ loop over base
      40      next_loop(e, set1);
      41
      42          a1 = heap(e+ebw1);
      43          a2 = heap(e+ebw2);
      44
      45          if a1 = om_val then  $ difference is null
      46              cont;
      47
      48          elseif a1 = a2 then  $ difference is null
      49              heap(e+ebw1) = om_val;
      50
      51          else    $ difference is a1
      52              card = card+1;
      53
      54          end if;
      55      end_next;
      56
      57
      58
      59      set_nelt(set1, card);
      60
      61      is_hashok(set1) = no;
      62
      63      build_spec(diflum, t_map, set1);
      64
      65      return;
      66
      67      end fnct diflum;
       1 .=member difrpm
       2      fnct difrpm(a1, a2);  $ remote packed map difference
       3
       4
       5      size difrpm(hs);     $ specifier returned
       6
       7      size a1(hs),     $ specifiers for two sets
       8           a2(hs);
       9
      10      size set1(ps),    $ pointers to two sets
      11           set2(ps),
      12           p1(ps),    $ pointers to their tuples
      13           p2(ps);
      14
      15      size len1(ps),    $ lengths of the two tuples
      16           len2(ps),
      17           min(ps),  $ minimum of len1 and len2
      18           v1(ps),     $ their packed values
      19           v2(ps);
      20
      21           size bits(ps),    $ bits/packed value
      22           card(ps),    $ cardinality of resut
      23           j(ps),    $ loop index over words of tuple
      24           org(ps);    $ loop index over bit origin in word
      25
      26
      27      set1 = value_ a1;  $ get pointers to sets
      28      set2 = value_ a2;
      29
      30$ we use a double loop over the tuples, one for sucessive words and
      31$ one for successive elements in a word.
      32
      33      card = 0;         $ cardinality of result
      34
      35      p1 = set1 + hl_rpmap;
      36      p2 = set2 + hl_rpmap;
      37
      38      len1 = maxindx(p1);  $ get lengths
      39      len2 = maxindx(p2);
      40
      41      bits = ptbits(p1);  $ bits per entry
      42
      43                  $ make set1 the smaller tuple
      44      min = len1;  $ find minimum length
      45      if (min > len2) min = len2;
      46
      47      do j = hl_ptuple to packoffs(p1, min);
      48
      49          do org = 1 to bpos_max by bits;
      50
      51              v1 = .f. org, bits, heap(p1+j);
      52              v2 = .f. org, bits, heap(p2+j);
      53
      54              if v1 = 0 then  $ difference is null
      55                  cont;
      56
      57              elseif v1 = v2 then  $ difference is null
      58                  .f. org, bits, heap(p1+j) = 0;
      59
      60              else         $ difference is v1
      61                  .f. org, bits, heap(p1+j) = v1;
      62                  card = card+1;
      63              end if;
      64
      65          end do;
      66      end do;
      67
      68 $ adjust -card- for remaining elements in set1
      69
      70      do j = packoffs(p1, min)+1 to packoffs(p1, len1);
      71          do org = 1 to bpos_max by bits;
      72
      73              if (.f. org, bits, heap(p1+j) ^= 0) card = card+1;
      74
      75          end do;
      76      end do;
      77
      78      set_nelt(set1, card);
      79
      80      is_hashok(set1) = no;
      81
      82      build_spec(difrpm, t_map, set1);
      83
      84      return;
      85
      86      end fnct difrpm;
       1 .=member difrum
       2      fnct difrum(arg1, arg2);  $ remote untyped map difference
       3
       4
       5      size difrum(hs);      $ specifier returned
       6
       7      size arg1(hs),      $ specifiers for two sets
       8           arg2(hs);
       9
      10      size set1(ps),     $ pointers to the sets
      11           set2(ps),
      12           tup1(ps),      $ pointers to their tuples
      13           tup2(ps);
      14
      15      size len1(ps),    $ length of the tuples
      16           len2(ps),
      17           min(ps);  $ minimum of len1 and len2
      18
      19      size card(ps),     $ cardinality of result
      20           om_val(hs),  $ untyoed om
      21           j(ps);    $ loop index over tuple components
      22
      23      size a1(hs),    $ tuple components
      24           a2(hs);
      25
      26
      27      set1 = value_ a1;  $ get pointers to sets
      28      set2 = value_ a2;
      29
      30      card = 0;         $ cardinality of result
      31
      32      tup1 = set1 + hl_rmap;
      33      tup2 = set2 + hl_rmap;
      34
      35$ get om image as it appears in tuples.
      36      om_val = tcomp(tup1, 0);
      37
      38      len1 = maxindx(tup1);  $ get its lengths.
      39      len2 = maxindx(tup2);
      40
      41                  $ make set1 the smaller tuple
      42      min = len1;  $ length of shorter tuple
      43      if (min > len2) min = len2;
      44
      45      do j = 1 to min;
      46
      47          a1 = tcomp(tup1, j);
      48          a2 = tcomp(tup2, j);
      49
      50          if a1 = om_val then  $ result is null
      51              cont;
      52
      53          elseif a1 = a2 then  $ result is null
      54              tcomp(tup1, j) = om_val;
      55
      56          else          $ result is a1
      57              card = card+1;
      58          end if;
      59      end do;
      60
      61$ adjust -card- to show remaining elements of set1
      62
      63      do j = min+1 to len1;
      64
      65          if (tcomp(tup1, j) ^= om_val) card = card+1;
      66
      67      end do;
      68
      69      set_nelt(set1, card);
      70
      71      is_hashok(set1) = no;
      72
      73      build_spec(difrum, t_map, set1);
      74
      75      return;
      76
      77      end fnct difrum;
       1 .=member setmod
       2      fnct setmod(arg1, arg2);
       3
       4$ this routine performs arg1//arg2 on two sets. its arguments are
       5
       6      size setmod(hs);    $ specifier returned
       7
       8      size arg1(hs),      $ specifiers for two arguments
       9           arg2(hs);
      10
      11      size t1(hs),     $ temporaries for result of a-b and b-a.
      12           t2(hs);
      13
      14
      15      size set1(ps),  $ pointers to the sets
      16           set2(ps);
      17
      18      size card(ps);  $ cardinality of result
      19
      20$ variables used for setmod on local sets
      21
      22      size ebw1(ps),    $ their ebwoeds
      23           ebw2(ps),
      24           ebb1(ps),    $ their ls_bits
      25           ebb2(ps),
      26           bit1(1),     $ current membership bits
      27           bit2(1),
      28           bit(1),  $ exclusive or of bit1 and bit2
      29           e(ps);       $ pointer to current eb of base
      30
      31$ variables for remote sets
      32
      33      size p1(ps),     $ pointers to their bit strings
      34           p2(ps),
      35           len1(ps),     $ lengths of their typles
      36           len2(ps),
      37           min(ps),  $ minimum of len1 and len2
      38           j(ps),   $ loop index over words of bit strings
      39           word(hs);   $ exor of current words of bit strings
      40
      41
      42      size setdiff(hs), $ functions called
      43           copy1(hs),
      44           union(hs);
      45
      46/begin/    $ begin execution
      47
      48
      49
      50$ only subsets on the same base are handled in line. all other
      51$ types are done by a brute force method using union and set difference.
      52
      53
      54      set1 = value_ arg1;  $ get pointers to sets
      55      set2 = value_ arg2;
      56
      57      go to case(htype(set1)) in h_uset to h_lrmap;
      58
      59/case(h_uset)/           $ all types but subsets branch here
      60/case(h_umap)/
      61
      62/case(h_lmap)/
      63
      64/case(h_rmap)/
      65
      66/case(h_lpmap)/
      67
      68/case(h_limap)/
      69
      70/case(h_lrmap)/
      71
      72/case(h_rpmap)/
      73
      74/case(h_rimap)/
      75
      76/case(h_rrmap)/
      77
      78
      79     $ since symmetric difference is rather rare, we
      80                    $ treat a//b as (a-b) + (b-a).
      81      t1 = setdiff(copy1(arg1), arg2);
      82      t2 = setdiff(copy1(arg2), arg1);
      83
      84      setmod = union(t1, t2, no);
      85
      86      return;
      87
      88
      89
      90/case(h_lset)/          $ local subset
      91
      92
      93
      94                       $ iterate over base, setting bits.
      95
      96      ebw1 = ls_word(set1);   $ ls_word_ for arg1
      97      ebw2 = ls_word(set2);
      98
      99      ebb1 = ls_bit(set1);
     100      ebb2 = ls_bit(set2);
     101
     102      card = 0;         $ cardinality of result
     103
     104      next_loop(e, set1);  $ iterate over base
     105
     106          bit1 = .f. ebb1, 1, heap(e+ebw1);
     107          bit2 = .f. ebb2, 1, heap(e+ebw2);
     108
     109          bit = bit1 .ex. bit2;
     110
     111          card = card+bit;
     112          .f. ebb1, 1, heap(e+ebw1) = bit;
     113
     114      end_next;
     115
     116      set_nelt(set1, card);
     117
     118      is_hashok(set1) = no;
     119
     120      setmod = arg1;
     121
     122      return;
     123
     124
     125
     126/case(h_rset)/        $ remote subset
     127
     128                        $ allocate a null set for result
     129
     130                         $ get pointers to bit strings for arguments
     131
     132      len1 = rswords(set1);
     133      len2 = rswords(set2);
     134
     135                        $ make set1 the longer.
     136      min = len1;  $ get minimum length
     137      if (min > len2) min = len2;
     138
     139                        $ get nullset.
     140      card = 0;                $ cardinality of result.
     141
     142      do j = 1 to min;
     143
     144          word = rsword(set1, j) .ex. rsword(set2, j);
     145          card = card + .nb. word;
     146          rsword(set1, j) = word;
     147
     148      end do;
     149
     150                           $ add rest of set1.
     151      do j = min+1 to len1;
     152
     153          word = rsword(set1, j);
     154          card = card + .nb. word;
     155
     156      end do;
     157
     158      set_nelt(set1, card);
     159
     160      is_hashok(set1) = no;
     161
     162      build_spec(setmod, t_set, set1);
     163
     164      return;
     165
     166      end fnct setmod;
     167
     168
     169 ..part2
       1 .=member with
       2 .+part3.
       3
       4
       5      fnct with(arg1, arg2);
       6
       7$ this is the top level routine for the 'with' operator. it is
       8$ called when the type of its arguments are unknown.
       9
      10$ we assume that arg1 can be destructively used and that arg2 has its
      11$ share bit set.
      12
      13
      14      size arg1(hs),  $ specifier for set or tuple
      15           arg2(hs);   $ specifier for element
      16
      17      size with(hs);  $ specifier returned
      18
      19      size a1(hs), $ copoes of arguments
      20           a2(hs);
      21
      22      size p(ps),  $ pointer to tuple
      23           indx(hs);  $ tupe index as setl short int
      24      size i(ps);             $ tuple index
      25      size fm(ps);            $ tuple form
      26
      27      size withs(hs);  $ function called
      28      size copy1(hs);         $ copy utility
      29      size convert(hs);       $ convertion utility
      30
      31
      32      a1 = arg1;  $ make local copies of arguments
      33      a2 = arg2;
      34
      35                 $ branch on type of first argument
      36
      37/switch/
      38
      39      go to case(otype_ a1) in t_min to t_max;
      40
      41
      42/case(t_int)/
      43
      44/case(t_string)/
      45
      46/case(t_atom)/
      47
      48/case(t_proc)/
      49
      50/case(t_lab)/
      51
      52/case(t_latom)/
      53
      54/case(t_lint)/
      55
      56/case(t_istring)/
      57
      58/case(t_real)/
      59
      60      call err_type(14);
      61
      62      with = err_val(f_gen);
      63
      64      return;
      65
      66/case(t_elmt)/    $ element
      67
      68      deref(a1);   maycopy(a1);
      69
      70      go to switch;
      71
      72/case(t_tuple)/
      73
      74      if is_om_ a2 then  $ return a1
      75          with = a1;
      76          return;
      77      end if;
      78
      79      p = value_ a1;   fm = hform(p);   i = nelt(p) + 1;
      80
      81      if ft_type(fm) = f_mtuple then
      82          if i > ft_lim(fm) then
      83              call err_misc(56);   go to error;
      84          end if;
      85
      86          fm = mttab(ft_elmt(fm)+i);
      87          a2 = convert(a2, fm);
      88      end if;
      89
      90      if i > maxindx(p) then
      91          call exptup(a1, i);   p = value_ a1;
      92      end if;
      93
      94      tcomp(p, i) = a2;   nelt(p) = i;
      95
      96      is_hashok(p) = no;
      97
      98      with = a1;
      99
     100      return;
     101
     102/case(t_stuple)/
     103
     104      if is_om_ a2 then
     105          with = a1;
     106          return;
     107      end if;
     108
     109      p = value_ a1;
     110
     111      if nelt(p) = maxindx(p) then
     112          call exptup(a1, nelt(p)+1);
     113          p = value_ a1;
     114      end if;
     115
     116      build_spec(indx, t_int, nelt(p)+1);
     117
     118      call sof(a1, indx, a2);
     119
     120      with = a1;
     121
     122      return;
     123
     124
     125
     126
     127/case(t_set)/
     128
     129/case(t_map)/
     130
     131      with = withs(a1, a2, no);
     132
     133      return;
     134
     135case_om;
     136
     137      call err_om(1);
     138      go to error;
     139
     140
     141/error/
     142
     143      if isprim(type_ a1) then
     144          with = err_val(f_gen);
     145      else
     146          with = err_val(hform(value_ a1));
     147      end if;
     148
     149      return;
     150
     151
     152      end fnct with;
       1 .=member withs
       2      fnct withs(set, elmt, decl);
       3
       4$ this routine performs the 'with' operation on sets and maps.
       5$ we assume that 'set' can be used destructively and that
       6$ the 'elmt' has its share bit set.
       7
       8$ 'decl' indicates that the inputs are declared and that the
       9$ result must have the same type as 'set'.
      10
      11
      12      size set(hs),   $ actual parameters
      13           elmt(hs),
      14           decl(1);  $ indicates declared inputs
      15
      16      size withs(hs);  $ specifier for result
      17
      18      size st(hs),     $ parameters to recursive part of routine
      19           el(hs);
      20
      21      size added(1); $ auxialliary output. indicates if element was adde
      22
      23      size tstart(ps);  $ pointer to recursion stack at start of routin
      24
      25      size hd(hs),    $ first component of pair being inserted into map
      26           tl(hs);     $ second component of pair
      27
smfc  28      size im(hs);            $ current image of -hd- in map
smfc  29      size temp(hs);          $ new image being set up
smfc  30      size ptr(ps);           $ pointer to new image
smfc  31      size pos(ps);           $ junk pointer for insert
      29
      30      size s(ps),  $ pointer to set
      31           p(ps); $ pointer to eb
      32
smfc  32      size copy1(hs);         $ copy utility
smfc  33      size convert(hs);       $ conversion utility
smfc  34      size equal(1);          $ equality utility
smfc  35      size fval(hs);          $ retrieves map image
smfc  36      size nullset(hs);       $ allocates nullset
      38
      39$ stacked variables
      40
      41 .=zzyorg b $ reset counters for stack offsets
      42
      43      local(retpt);  $ return pointer
      44
      45      local(s1);  $ copy of s
      46      local(p1);  $ copy of p
      47      local(pair);     $ pointer to pair being inserted into map
      48
      49
      50
      51
      52/begin/               $ begin execution
      53
      54      if is_om_ elmt then
      55          call err_om(2);
      56          withs = set;
      57          return;
      58      end if;
      59
      60      if is_om_ set then
      61          call err_om(01);   withs = err_val(hform(value_ set));
      62          return;
      63      end if;
      64
      65
      66      tstart = t;  $ save initial stack pointer
      67
      68 .=zzyorg a    $ reset counter for return labels
      69
      70      st = set;             $ make local copies of arguments
      71      el = elmt;
      72
      73
      74
      75/entry/               $ recursive entry point
      76
      77
      78      r_entry;  $ increment recursion stack
      79
      80      s = value_ st;       $ get pointer to set header
      81
      82
      83      if (^ is_map(s)) go to case_set; $ catch set case.
      84
      85
      86/case_map/            $ maps
      87
      88$ begin by checking whether el is a pair. if not, then st and el
      89$ must both be undeclared. in this case we convert st to a standard
      90$ set.
      91
      92      if (otype_ el ^= t_tuple) go to conv;
      93      if (nelt(value_ el) ^= 2) go to conv;
      94      if (is_om_ tcomp(value_ el, 1)) go to conv;
      95
      96$ otherwise el is a pair, and we procedd to insert it into the
      97$ map. this is done in four steps:
      98
      99$ 1. split el into a pair .
     100
     101$ 2. locate -hd- in its domain and set -im- to its image.
     102
     103$ 3. merge -tl- and -im-. set -added- to indicate whether -tl-
     104$    was added to the image.
     105
     106$ 4. if -added- is set, store the new image and adjust the nelt
     107$    and hash.
     108
     109      pair = value_ el;  $ get pointer to pair
     110
     111      hd = tcomp(pair, 1);
     112      tl = tcomp(pair, 2);
     113
     114
     115      call locate(p, hd, s, yes);  $ locate and insert head
     116
     117$ see if we are adding to hd-s image.
     118
     119      im = fval(s, p, no);
     120
     121      if is_multi_ im then  $ multivalued. do -with- recursively
     122          s1 = s;         $ save across recursion
     123          p1 = p;
     124
     125          st = im;
     126          maycopy(st);
     127
     128          el = tl;
     129          is_shared_ el = yes;
     130
     131          r_call;
     132
     133          im = withs;   $ set up new image value
     134          is_multi_ im = yes;
     135
     136          s = s1;   $ restore sized variables
     137          p = p1;
     138
     139          added = yes;
     140
     141      elseif is_om_ im then  $ new image is tl
     142          im = tl;
     143          added = yes;
     144
     145      elseif eq(im, tl) then  $ no change to image
     146          added = no;
     147
     148      elseif ne(im, tl) then  $ use << im, tl >>
     149          if (is_smap(s)) go to smap; $ smap becoming multivalued
     150
smfc  37          temp = nullset(ft_imset(hform(s)), 2); ptr = value_ temp;
smfc  38          call insert(pos, im, ptr); call insert(pos, tl, ptr);
smfc  39          value_ temp = ptr; is_multi_ temp = yes; im = temp;
     153
     154          added = yes;
     155
     156      elseif equal(im, tl) then $ no change
     157          added = no;
     158
     159      else           $ unequal. use << im, tl >>
     160          if (is_smap(s)) go to smap; $ smap becoming multivalued
     161
smfc  40          temp = nullset(ft_imset(hform(s)), 2); ptr = value_ temp;
smfc  41          call insert(pos, im, ptr); call insert(pos, tl, ptr);
smfc  42          value_ temp = ptr; is_multi_ temp = yes; im = temp;
     164
     165          added = yes;
     166      end if;
     167
     168
smfc  43$ store the new image if necessary.  note that adding a new image to a
smfc  44$ remote map may mean moving the set header and thus modifying s.
smfc  45
     172      if added then
     173          call sfval(s, p, im);
     174          is_shared_ tcomp(pair, 2) = yes;
     175
     176          up_nelt(s, 1);
     177          is_hashok(s) = no;
     178      end if;
     179
     180      build_spec(withs, t_map, s);
     181
     182      go to exit;
     183
     184/smap/             $ smap becoming multivalued.
     185
     186      if decl then
     187          call err_misc(26);
     188          go to error_exit;
     189      end if;
     190
     191      build_spec(st, t_map, s);  $ convert st to standard map
     192      st = convert(st, f_umap);
     193      s  = value_ st;
     194
     195      go to case_map;
     196
     197
     198
     199/conv/        $ convert set to map
     200
     201      if decl then
     202          call err_misc(27);
     203          go to error_exit;
     204      end if;
     205
     206      call convset(st);
     207      s = value_ st;
     208
     209/case_set/                                 $ set cases
     210
     211$ for sets we do a locate, adding the element if necessary.
     212$ if -set- is based, we set the proper membership bit
     213
     214      call locate(p, el, s, yes);
     215      added = (^ loc_found);  $ flag added element
     216
     217      if (is_based(s)) call sfval(s, p, yes);  $ set subset bit
     218
     219
     220      if added then  $ adjust nelt and hash
     221          up_nelt(s, 1);
     222          up_hash(s, loc_hash);
     223      end if;
     224
     225      build_spec(withs, t_set, s);  $ build specifier for result
     226
     227
     228/exit/                        $ recursive exit point
     229
     230      r_exit;   $ pop recursion stack
     231
     232      if t ^= tstart  then      $ recursive return
     233          go to rlab(retpt) in 1 to zzya;
     234      else                      $ actual return
     235          return;
     236      end if;
     237
     238
     239/error_exit/
     240
     241      withs = err_val(hform(value_ set));
     242
     243      t = tstart;
     244      return;
     245
     246
     247$ drop local variables
     248
     249      macdrop2(retpt, s1)
     250      macdrop2(pair, p1)
     251
     252      end fnct withs;
       1 .=member withm
       2      fnct withm(set, n, decls);
       3
       4$ this is a special version of with used to insert pairs into maps.
       5$ it is particularly useful when we desire to build a map as a set
       6$ of pairs, i.e.
       7
       8$    f = <<  in f1 st c(x, y) >>;
       9
      10$ the user should not be discouraged from building maps in this way
      11$ on the basis that it means building alot of pairs which are
      12$ immediately thrown away. instead we use a special map former which
      13$ builds a map by calling withm.
      14
      15$ withm is called to perform
      16
      17$    f = f with.   >>
      18
      19$ where f has been declared an n variate map or smap.
      20$ rather than passing withm a specifier for the nested object on the
      21$ right hand side, we pass it x1 ... xn+1 directly. these are passed
      22$ through the stack. xi is located at heap(t-1+i). as usual, withm
      23$ uses these locations, but assumes that its caller pops the stack.
      24$ pops the stack when its done.
      25
      26$ withm can force an smap to become multi valued. if this happens
      27$ we either convert the smap to a general map or abort, depending
      28$ on whether the map was declared singlevalued. this is given by
      29$ the parameter 'decls'.
      30
      31$ there are two possibilities: either the map is declared an
      32$ smap(decls = yes), in which case we abort, or it is declared
      33$ general(decls = no), in which case we convert it to a standard
      34$ map and try again.
      35
      36
      37      size withm(hs);  $ specifier returned
      38
      39 .-dead.
      40      call err_fatal(57);
      41 .+dead.
      42
      43      size set(hs),   $ specifier for top level map
      44           n(ps),  $ number of arguments to mapping
      45           decls(1);  $ flags declared smap
      46
      47      size st(hs),     $ parameters to recursive part of routine
      48           argno(ps), $ current argument no
      49           arg(hs);  $ argument to mapping
      50
      51      size added(1); $ auxialliary output. indicates if element was adde
      52
      53      size tstart(ps);  $ pointer to recursion stack at start of routin
      54
      55      size tl(hs), $ tail of innermost 'pair'
      56           im(hs);    $ current image of -arg- in map
      57
      58      size s(ps),  $ pointer to set
      59           p(ps); $ pointer to eb
      60
      61
      62      size fval(hs),  $ functions called
      63           copy1(hs),
      64           equal(1),
      65           rset2(hs);
      66
      67$ stacked variables
      68
      69 .=zzyorg b $ reset counters for stack offsets
      70
      71      local(retpt);  $ return pointer
      72
      73      local(s1);  $ copy of s
      74      local(p1);  $ copy of p
      75
      76
      77
      78
      79/begin/               $ begin execution
      80
      81      if ^ isset(otype_ s) then
      82          call err_type(15);
      83          withm = err_val(f_gen);
      84          return;
      85      end if;
      86
      87      tstart = t;  $ save initial stack pointer
      88
      89 .=zzyorg a    $ reset counter for return labels
      90
      91
      92      st = set;             $ make local copy oset f
      93      argno = 0;  $ initialize argno
      94
      95
      96
      97/entry/               $ recursive entry point
      98
      99
     100      r_entry;  $ increment recursion stack
     101
     102      s = value_ st;       $ get pointer to set header
     103
     104      argno = argno+1;  $ get next argument to mapping
     105      arg = heap(tstart + argno - 1);
     106
     107
     108      if (^ is_map(s)) go to case_set; $ catch set case.
     109
     110
     111/case_map/            $ maps
     112
     113$ begin by locating arg in the domain and saving it through recursion
     114      call locate(p, s, arg, yes);
     115
     116      if is_multi_ im then  $ multivalued. do -with- recursively
     117          s1 = s;  $ save across recursion
     118          p1 = p;
     119
     120          st = im;
     121          maycopy(st);
     122
     123          r_call;
     124
     125          im = withm;   $ set up new image value
     126          is_multi_ im = yes;
     127
     128          s = s1;  $ restore
     129          p = p1;
     130
     131          added = yes;
     132      else    $ merge tail of innermost 'pair' with im
     133          tl = heap(tstart-1 + (argno+1));
     134
     135          if is_om_ im then  $ new image is tl
     136              im = tl;
     137              added = yes;
     138
     139          elseif eq(im, tl) then  $ no change to image
     140              added = no;
     141
     142          elseif ne(im, tl) then  $ use << im, tl >>
     143              if (is_smap(s)) go to smap; $ smap becoming multivalued
     144
     145              im = rset2(im, tl);
     146          is_multi_ im = yes;
     147
     148              added = yes;
     149
     150          elseif equal(im, tl) then $ no change
     151              added = no;
     152
     153          else           $ unequal. use << im, tl >>
     154              if (is_smap(s)) go to smap; $ smap becoming multivalued
     155
     156              im = rset2(im, tl);
     157          is_multi_ im = yes;
     158
     159              added = yes;
     160          end if;
     161
     162      end if;
     163
     164
     165$ store the new image if necessary. note that adding a new image
     166$ to a remote map may mean moving the set header and thus modifying
     167$ s.
     168      if added then
     169          call sfval(s, p, im);
     170
     171          up_nelt(s, 1);
     172          is_hashok(s) = no;
     173      end if;
     174
     175      build_spec(withm, t_map, s);
     176
     177      go to exit;
     178
     179
     180
     181/smap/             $ smap becoming multivalued.
     182
     183      if (decls) go to error_exit;
     184
     185$ convert s to a standard map. note that this is a 1 level conversion.
     186      build_spec(st, t_map, s);
     187      call convset(st);
     188
     189      go to case_map;
     190
     191
     192/case_set/                                 $ set cases
     193
     194$ set cases occur at the bottom level of a multivalued map.
     195
     196$ for sets we do a locate, adding the element if necessary.
     197$ if -set- is based, we set the proper membership bit
     198
     199      call locate(p, arg, s, yes);
     200      added = (^ loc_found);  $ flag added element
     201
     202      if (is_based(s)) call sfval(s, p, yes);  $ set subset bit
     203
     204
     205      if added then  $ adjust nelt and hash
     206          up_nelt(s, 1);
     207          up_hash(s, loc_hash);
     208      end if;
     209
     210      build_spec(withm, t_set, s);  $ build specifier for result
     211
     212
     213/exit/                        $ recursive exit point
     214
     215      r_exit;  $ pop recursion stack
     216
     217      if t ^= tstart  then      $ recursive return
     218          go to rlab(retpt) in 1 to zzya;
     219      else                      $ actual return
     220          free_stack(n+1);
     221          return;
     222      end if;
     223
     224
     225/error_exit/                  $ error exit
     226
     227      call err_misc(28);
     228
     229      withm = err_val(f_gen);
     230
     231      t = tstart;
     232      return;
     233
     234
     235$ drop local variables
     236
     237      macdrop (retpt)
     238      macdrop2(s1, p1)
     239
     240 ..dead
     241
     242
     243      end fnct withm;
       1 .=member less
       2      fnct less(set, elmt);
       3
       4$ this routine performs the -less- function. set and elmt are specifiers
       5$ for the two inputs, and a specifier for the result is returned.
       6
       7$ the logic of -less- is very close to the logic of -with-.
       8
       9$ less destroys its first argument. we assume that by the time we
      10$ reach the recursive entry point the set -st- can be modified.
      11
      12
      13      size less(hs);    $ specifier returned
      14
      15      size set(hs),    $ specifiers for arguments to routine
      16           elmt(hs);
      17
      18      size st(hs),   $ arguments to recursive parts of routine
      19           el(hs);
      20
      21      size found(1);  $ auxilliary output. on if element found
      22
      23      size hd(hs),  $ specifiers for components of pair
      24           tl(hs);
      25
      26      size im(hs);   $ current image of -hd-
      27
      28      size tstart(ps);  $ initial recursion stack pointer
      29
      30      size pos(ps);  $ value return parameter for locate
      31
      32
      33      size fval(hs),  $ functions called
      34           copy1(hs),
      35           arbs(hs),
      36           equal(1);
      37
      38
      39$ stacked variables
      40
      41 .=zzyorg b $ reset counters for stack offsets
      42
      43      local(retpt);   $ return pointer
      44
      45      local(s);   $ pointer to set
      46      local(p);    $ pointer returned by locate
      47      local(prev);  $ saved value of loc_prev
      48      local(n);   $ nelt of map image
      49
      50
      51
      52
      53/begin/                     $ begin execution
      54
      55      tstart = t;  $ save initial stack pointer
      56
      57 .=zzyorg a    $ reset counter for return labels
      58
      59
      60      if is_om_ elmt then  $ return original set
      61          less = set;
      62          return;
      63      end if;
      64
      65      st = set;                  $ make local copies of arguments.
      66      el = elmt;
      67
      68      if otype_ st = t_elmt then
smfb  90          deref(st);   st = copy1(st);
      70      end if;
      71
      72      if ^ isset(otype_ st) then
      73          call err_type(16);
      74          less = err_val(f_gen);
      75          return;
      76      end if;
      77
      78
      79
      80
      81/entry/                    $ recursive point
      82
      83
      84      r_entry;   $ increment recursion stack
      85
      86      s = value_ st;              $ get pointer to set header.
      87
      88      go to case(htype(s)) in h_uset to h_lrmap;
      89
      90
      91
      92/case(h_uset)/                 $ standard set
      93
      94      call locate(pos, el, s, no);        $ try to locate el in s.
      95      found = loc_found;   $ delete element if found
      96
      97      if found then $ delete element
      98          call delete(s, loc_prev, pos, yes);
      99          down_nelt(s, 1);
     100          down_hash(s, loc_hash);
     101      end if;
     102
     103      build_spec(less, t_set, s);
     104
     105      go to exit;
     106
     107
     108/case(h_lset)/          $ based sets
     109
     110/case(h_rset)/
     111
     112      call locate(pos, el, s, no);   $ try to locate in base
     113      found = fval(s, pos, no);  $ delete if currently in set
     114
     115
     116      if found then
     117          call sfval(s, pos, no);   $ turn off membership bit
smfb  91          down_nelt(s, 1);
smfb  92          down_hash(s, loc_hash);
     120      end if;
     121
     122      build_spec(less, t_set, s);
     123
     124      go to exit;
     125
     126
     127/case(h_umap)/          $ maps
     128
     129/case(h_lmap)/
     130
     131/case(h_rmap)/
     132
     133/case(h_lpmap)/
     134
     135/case(h_limap)/
     136
     137/case(h_lrmap)/
     138
     139/case(h_rpmap)/
     140
     141/case(h_rimap)/
     142
     143/case(h_rrmap)/
     144
     145
     146$ the code here uses the same four steps described in the with routine
     147
     148      if      (otype_ el ^= t_tuple)        !
     149              (nelt(value_ el) ^= 2)        !
     150              (is_om_ tcomp(value_ el, 1)) then
     151          less = st;
     152          go to exit;
     153      end if;
     154
     155$ begin by splitting the pair into its head and tail, then locate
     156$ the head in the domain of the map and get its image.
     157
     158      hd = tcomp(value_ el, 1);
     159      tl = tcomp(value_ el, 2);
     160
     161$ locate head and save pointer through recursion.
     162      call locate(pos, hd, s, no);
     163      p = pos;
     164      prev = loc_prev;
     165
     166$ set -im- to hd-s new image. at the same time set -n- to
     167$ its nelt, and set -drop- if something is being removed from the map.
     168
     169      im = fval(s, pos, no);      $ get old image.
     170
     171      if is_multi_ im then         $ perform -less- recursively.
smfb  93          st = im; maycopy(st);
     174          el = tl;
     175
     176          r_call;
     177
     178          im = less;  $ process result
     179          is_multi_ im = yes;
     180
     181          ok_nelt(im);  $ get nelt and drop singletons if necessary
     182          n = nelt(value_ im);
     183
     184          if n = 0 then   $ replace with template
     185              im = om_image(s);
smfb  94              if is_mmap(s) then
smfb  95                  is_om_ im = no; is_multi_ im = yes;
smfb  96              end if;
smfb  97
     186          elseif n = 1 & ^ is_mmap(s) then
     187              im = arbs(im);
     188          end if;
     189
     192          found = yes;
     193
     194      elseif eq(tl, im) then   $ new image is om
     195          im = om_image(s);
     196          n = 0;
     197          found = yes;
     198
     199      elseif ne(tl, im) then
     200          found = no;
     201
     202      elseif equal(tl, im) then   $ image is om
     203          im = om_image(s);
     204          n = 0;
     205          found = yes;
     206
     207      else
     208          found = no;
     209      end if;
     210
     211
     212      if found then   $ modify map
     213          if n = 0 & ^ is_based(s) then   $ delete eb
     214              call delete(s, prev, p, yes);
     215          else        $ store new image
     216              call sfval(s, p, im);
     217          end if;
     218
     219          is_hashok(s) = no;
     220          down_nelt(s, 1);
     221      end if;
     222
     223      build_spec(less, t_map, s);
     224
     225
     226
     227
     228
     229/exit/                     $ recursive exit
     230
     231      r_exit;    $ pop recusion stack
     232
     233      if t ^= tstart then        $ local return
     234          go to rlab(retpt) in 1 to zzya;
     235      else                      $ actual return
     236          return;
     237      end if;
     238
     239
     240
     241$ drop local variables
     242
     243      macdrop2(s, p)
     244      macdrop2(prev, n)
     245      macdrop(retpt)
     246
     247      end fnct less;
       1 .=member from
       2      subr from(x, s);
       3
       4$ this routine performs 'x from s' when the type
       5$ of its argument is not known.
       6
       7$ we copy the set or tuple if it is shared.
       8
       9
      10      size x(hs);             $ specifier for element extracted
      11      size s(hs);             $ specifier for set_mode
      12
      13      size fm(ps);            $ form of s
      14
      15
      16      deref(s);
      17
      18      if ^ isset(otype_ s) then
      19          if is_om_ s then
      20              call err_om(3);
      21          else
      22              call err_type(17);
      23          end if;
      24
      25          if isprim(type_ s) then
      26              x = err_val(f_gen);
      27              s = err_val(f_gen);
      28          else
      29              fm = hform(value_ s);
      30
      31              if ft_type(fm) = f_mtuple then
      32                  x = err_val(f_gen);
      33              else
      34                  x = err_val(ft_elmt(fm));
      35              end if;
      36
      37              s = err_val(fm);
      38          end if;
      39
      40      else
      41          call froms(x, s);
      42      end if;
      43
      44
      45      end subr from;
       1 .=member froms
       2      subr froms(elmt, set);
       3
       4$ this routine performs the 'from' primitive on sets and maps.
       5$ it is written in a style which is a cross between the 'arbs'
       6$ and 'less' routines.
       7
       8$ 'froms' is naturally recursive in order to handle multi valued
       9$ maps. the intuitive algorithm for treating maps is s follows:
      10
      11$ 1. iterate over the domain of the map, finding the first
      12$    domain element 'x' for which the map is defined.
      13
      14$ 2. perform 'from' on f<> recursively, yielding some value
      15$    't'.
      16
      17$ 3. return the pair [x, t].
      18
      19$ this algorithm would remove an element from the bottom level
      20$ map then make a recursive return and allocate a pair for the
      21$ result of the top level map.
      22
      23$ the above algorithm is quite natural, but would throw off
      24$ the garbage collector if we ran out of space between the
      25$ time we modified the lower level map and the time we allocated
      26$ the new pair. instead we must use a somewhat less intuitive
      27$ algorithm which allocates the new pair at the end of step 1.
      28
      29$ at each level we must copy the set if it is shared.
      30
      31
      32$ variable declarations
      33
      34      size elmt(hs), $ specifier for element returned
      35           set(hs);  $ specifier for set
      36
      37      size tstart(ps);  $ recursion stack pointer at start of routine
      38
      39      size hd(hs),    $ head of pair
      40           tl(hs);  $ tail of pair
      41
      42      size p(ps),  $ pointer to pair
      43           n(ps);  $ 'nelt' of image.
      44
      45      size bit(ps),  $ ls_bit of set
      46           word(ps),  $ ls_word
      47           indx(ps); $ ebindx
      48
      49
      50
      51      size nullp(1),   $ functions called
      52           copy1(hs),
      53           arbs(hs),
      54           fval(hs);
      55
      56$ stacked variables
      57
      58 .=zzyorg b $ reset counters for stack offsets
      59
      60      local(retpt);     $ return pointer
      61
      62      local(s);      $ pointer to set
      63
      64      local(e);  $ pointer to eb
      65      local(prev);  $ pointer to previous eb
      66
      67      local(pair);  $ specifier for pair returned
      68      local(im);  $ image of head in map
      69
      70
      71/begin/             $ begin execution
      72
      73      tstart = t;         $ save initial recursion stack pointer
      74
      75 .=zzyorg a    $ reset counter for return labels
      76
      77
      78/entry/          $ recursive entry point
      79
      80      r_entry;   $ increment recursion stack
      81
      82      maycopy(set);
      83      s = value_ set;
      84
      85      if (^ is_map(s)) go to case_set;   $ branch for sets
      86
      87
      88/case_map/                $ map cases
      89
      90
      91
      92$ find domain element
      93
      94$ iterate over s till we find an element -e- whose image is defined.
      95$ set -im- to its image.
      96
      97      prev = 0;  $ initialize pointer to previous eb
      98
      99      next_loop(e, s);
     100          im = fval(s, e, yes);
     101
     102          if is_mmap(s) then  $ look for non-null image
     103              p = value_ im;   $ get pointer to range set
     104
     105              if is_neltok(p) then  $ quit if range set is non-null.
     106                  if (nelt(p) ^= 0) quit;
     107              else
     108                  if (^ nullp(p)) quit;
     109              end if;
     110          else  $ look for defined image
     111              if (^ is_om_ im) quit;
     112          end if;
     113
     114          prev = e;  $ save pointer to last eb
     115
     116      end_next;
     117
     118
     119$ allocate a pair and store the domain element
     120
     121      get_pair(p);
     122      build_spec(pair, t_tuple, p);
     123
     124      hform(p) = ft_elmt(hform(s));  $ put in full repr information
     125
     126      if is_based(s) then  $ return pointer to base
     127          build_spec(hd, t_elmt, e);
     128      else   $ return domain specifier
     129          is_shared_ ebspec(e) = yes;
     130          hd = ebspec(e);
     131      end if;
     132
     133      tcomp(value_ pair, 1) = hd;
     134      if (is_ebtemp(e)) is_om_ pair = yes;  $ indicate end of set
     135
     136
     137
     138$ remove  - tl from. im -
     139
     140$ set -tl- to an element of -im-, -im- to the reduced image, and
     141$ -n- to its nelt.
     142
     143
     144      if is_multi_ im then  $ do -from- on image
     145          set = im;
     146
     147          r_call;
     148
     149          tl = elmt;
     150          im = set;
     151          is_multi_ im = yes;
     152
     153          ok_nelt(im);  $ get nelt of image.
     154          n = nelt(value_ im);
     155
     156          if n = 0 then  $ null result
     157              im = om_image(s);
smfb  98              if is_mmap(s) then
smfb  99                  is_om_ im = no; is_multi_ im = yes;
smfb 100              end if;
     158          elseif n = 1 & ^ is_mmap(s) then   $ remove singleton
     159              im = arbs(im);
     160          end if;
     161
     162      else     $ image single valued
     163          tl = im;
     164          im = om_image(s);
     165          n = 0;
     166      end if;
     167
     168$ delete pair from map
     169
     170      if n = 0 & ^ is_based(s) then  $ delete eb
     171          call delete(s, prev, e, yes);
     172      else         $ store im
     173          call sfval(s, e, im);
     174      end if;
     175
     176      down_nelt(s, 1);
     177      is_hashok(s) = no;
     178
     179
     180
     181$ store tl in pair and return
     182
     183      tcomp(value_ pair, 2) = tl;
     184
     185      elmt = pair;
     186      build_spec(set, t_map, s);
     187
     188      go to exit;
     189
     190
     191
     192
     193/case_set/             $ set cases
     194
     195      go to sc(htype(s)) in h_uset to h_rset; $ jump on type
     196
     197
     198/sc(h_uset)/       $ unbased set
     199
     200$ look for the first element which is not a dummy hash header. we
     201$ do this with a next_loop which quits the first time we enter
     202$ the body of the loop.
     203
     204      next_loop(e, s);
     205
     206          quit;
     207
     208      end_next;
     209
     210      elmt = ebspec(e);
     211
     212      call delete(s, 0, e, yes);
     213
     214      down_nelt(s, 1);  $ adjust nelt and hash
     215      is_hashok(s) = no;
     216
     217      build_spec(set, t_set, s);
     218
     219      go to exit;
     220
     221
     222
     223/sc(h_lset)/     $ based sets
     224
     225/sc(h_rset)/
     226
     227      next_loop(e, s);
     228
     229          if (fval(s, e, no)) quit;
     230
     231      end_next;
     232
     233      call sfval(s, e, no);  $ delete from set
     234
     235$ build specifier then adjust nelt and hash.
     236
     237      down_nelt(s, 1);
     238      hash(s) = hash(s) - ebhash(e);
     239
     240      build_spec(elmt, t_elmt, e);  $ value is element of base
     241      if (is_ebtemp(e)) is_om_ elmt = yes;
     242
     243      build_spec(set, t_set, s);
     244
     245      go to exit;
     246
     247
     248
     249/exit/             $ recursive exit
     250
     251      r_exit;   $ pop recursion stack
     252
     253      if t ^= tstart then     $ recursive return
     254          go to rlab(retpt) in 1 to zzya;
     255
     256      else
     257          return;
     258      end if;
     259
     260
     261
     262$ drop local variables
     263
     264      macdrop8(retpt, s, e, prev, hd, tl, im, ended)
     265      macdrop(pair)
     266
     267      end subr froms;
       1 .=member fromb
       2      subr fromb(elmt, tuple);
       3
       4$ this routine computes 'elmt fromb tuple'.
       5$
       6$ we treat it as '[elmt, tuple] := [tuple(1), tuple(2..)]'.
       7
       8
       9      size elmt(hs);          $ specifier for left operand
      10      size tuple(hs);         $ specifier for right operand
      11
      12      size p(ps);             $ pointer to tuple
      13      size val(hs);           $ untyped value
      14      size card(ps);          $ its cardinality
      15      size indx(ps);          $ loop index
      16
      17      size copy1(hs);         $ function called
      18
      19
      20      deref(tuple);
      21
      22      if ^ istuple(otype_ tuple) then
      23          if is_om_ tuple then
      24              call err_om(28);
      25          else
      26              call err_type(62);
      27          end if;
      28
      29          elmt  = err_val(f_gen);
      30          tuple = err_val(f_gen);
      31
      32          return;
      33      end if;
      34
      35      maycopy(tuple);
      36
      37      p    = value_ tuple;
      38      card = nelt(p);
      39
      40      if (htype(p) = h_ptuple) go to packed;
      41
      42
      43      if card > 0 then
      44          elmt         = tcomp(p, 1);
      45          nelt(p)      = card - 1;
      46          is_hashok(p) = no;
      47
      48          do indx = 2 to card;
      49              tcomp(p, indx-1) = tcomp(p, indx);
      50          end do;
      51
      52          tcomp(p, card) = tcomp(p, 0);
      53
      54      else
      55          elmt = tcomp(p, 0);
      56      end if;
      57
      58      return;
      59
      60
      61/packed/
      62
      63      if card > 0 then
      64          val          = pcomp(p, 1);
      65          nelt(p)      = card - 1;
      66          is_hashok(p) = no;
      67
      68          do indx = 2 to card;
      69              pcomp(p, indx-1) = pcomp(p, indx);
      70          end do;
      71
      72          pcomp(p, card) = 0;
      73
      74      else
      75          val = 0;
      76      end if;
      77
      78      unpack(ptkey(p), val, elmt);
      79
      80      return;
      81
      82
      83      end subr fromb;
       1 .=member frome
       2      subr frome(elmt, tuple);
       3
       4$ this routine computes 'elmt frome tuple'.
       5$
       6$ we treat it as '[elmt, tuple] := [tuple(#tuple), tuple(1..#tuple-1)]'.
       7$
       8$ n.b. if t = [1, om, om, 4], then the result of 'x frome t' is
       9$      x = 4, t = [1], since we don't save omegas at the end of
      10$      the tuple.
      11
      12
      13      size elmt(hs);          $ specifier for left operand
      14      size tuple(hs);         $ specifier for right operand
      15
      16      size p(ps);             $ pointer to tuple
      17      size fm(ps);            $ tuple form
      18      size om_val(hs);        $ proper omega for tuple component
      19      size val(hs);           $ untyped value
      20      size card(ps);          $ its cardinality
      21
      22      size copy1(hs);         $ function called
      23
      24
      25      deref(tuple);
      26
      27      if ^ istuple(otype_ tuple) then
      28          if is_om_ tuple then
      29              call err_om(29);
      30          else
      31              call err_type(63);
      32          end if;
      33
      34          elmt  = err_val(f_gen);
      35          tuple = err_val(f_gen);
      36
      37          return;
      38      end if;
      39
      40      maycopy(tuple);
      41
      42      p    = value_ tuple;
      43      card = nelt(p);
      44
      45      if (htype(p) = h_ptuple) go to packed;
      46
      47
      48      om_val = tcomp(p, 0);
      49
      50      if card > 0 then
      51          elmt         = tcomp(p, card);
      52          is_hashok(p) = no;
      53
      54          fm = hform(p);
      55
      56          if ft_type(fm) = f_mtuple then
smfb 101              om_val = heap(ft_samp(mttab(ft_elmt(fm)+card)));
smfb 102          end if;
smfb 103
smfb 104          tcomp(p, card) = om_val;
smfb 105
smfb 106          if otype_ tuple = t_tuple then
smfb 107              until card = 0;
smfb 108                  card = card - 1;
smfb 109                  if ( ^ is_om_ tcomp(p, card)) quit until;
smfb 110              end until;
smfb 111          else
smfb 112              until card = 0;
smfb 113                  card = card - 1;
smfb 114                  if (tcomp(p, card) ^= om_val) quit until;
smfb 115              end until;
smfb 116          end if;
smfb 117
smfb 118          nelt(p) = card;
      63
      64      else
      65          elmt = om_val;
      66      end if;
      67
      68      return;
      69
      70
      71/packed/
      72
      73      if card > 0 then
      74          val            = pcomp(p, card);
      75          pcomp(p, card) = 0;
      76          is_hashok(p)   = no;
      77
      78          until card = 0;
      79              card = card - 1;
      80              if (pcomp(p, card) ^= 0) quit until;
      81          end until;
      82
      83          nelt(p) = card;
      84
      85      else
      86          val = 0;
      87      end if;
      88
      89      unpack(ptkey(p), val, elmt);
      90
      91      return;
      92
      93
      94      end subr frome;
       1 .=member lessf
       2      fnct lessf(st, el);
       3
       4$ this routine performs the -lessf- function. set and elmt are specifier
       5$ for the two inputs, and a specifier for the result is returned.
       6
       7
       8      size lessf(hs);   $ specifier returned
       9
      10      size st(hs),      $ specifier for set
      11           el(hs);      $ specifier for domain element
      12
      13      size s(ps),      $ pointer to set
      14           pos(ps),    $ pointer returned by locate
      15           im(hs);    $ image of el
      16
      17      size fval(hs),  $ functions called
      18           convsm(hs);
      19      size copy1(hs);         $ copy utility
      20
      21
      22      lessf = st;
      23
      24      if otype_ lessf = t_elmt then
smfb 119          deref(lessf);   lessf = copy1(lessf);
      26      end if;
      27
      28      if (otype_ lessf = t_set) lessf = convsm(lessf, f_umap);
      29
      30      if otype_ lessf ^= t_map then
      31          if is_om_ lessf then
      32              call err_om(05);
      33          else
      34              call err_type(18);
      35          end if;
      36
      37          lessf = err_val(f_gen);
      38          return;
      39      end if;
      40
      41      s = value_ lessf;
      42
      43      call locate(pos, el, s, no);  $ do locate
      44      if (^ loc_found) go to exit;
      45
      46      if is_based(s) then
      47          im = om_image(s);
      48
      49          if is_mmap(s) then
      50              is_om_ im = no;   is_multi_ im = yes;
      51          end if;
      52
      53          call sfval(s, pos, im);
      54      else
      55          call delete(s, loc_prev, pos, yes);
      56      end if;
      57
      58
      59/exit/
      60
      61      is_hashok(s) = no;
      62      is_neltok(s) = no;
      63
      64
      65      end fnct lessf;
       1 .=member member
       2      fnct member(arg1, arg2);
       3
       4$ this routine tests arg1 for membership in arg2. arg2 may be a
       5$ set, tuple, character string or bit string.
       6
       7$ set membership is handled through a lower level routine -memset-.
       8$ membership testing on all other types is very rare and is done
smfb 120$ through a very simple algorithm: we iterate from 1 to # arg2
      10$ applying -of- and testing for equality with arg1. the f(x)
      11$ operation is done by actually calling -of-. as a result the
      12$ loop index must be a setl integer.
      13
      14$ the routine begins with a branch on type. for most types, we merely
smfb 121$ calculate # arg2 as a setl short integer and branch to the standard
      16$ loop.
      17
      18
      19      size member(1);         $ boolean value returned
      20
      21      size arg1(hs);          $ specifier for left operand
      22      size arg2(hs);          $ specifier for right operand
      23
      24      size a1(hs);            $ local copies of operands
      25      size a2(hs);            $ ...
      26      size ss1(ssz);          $ string specifiers for operands
      27      size ss2(ssz);          $ ...
      28      size len1(ps);          $ length of first operand
      29      size len2(ps);          $ length of second operand
      30      size j1(ps);            $ indices
      31      size j2(ps);            $ ...
      32      size indx(hs);          $ specifier for loop index
      33      size lim(hs);           $ specifier for loop limit
      34      size elmt(hs);          $ specifier returned by -of- routine
      35
      36      size equal(1);          $ equality routine
      37      size memset(1);         $ set membership routine
      38
      39
      40      a1 = arg1;  $ copy arguments
      41      a2 = arg2;
      42
      43/switch/
      44
      45      go to case(otype_ a2) in t_min to t_max;  $ branch on type_
      46
      47/case(t_int)/                  $ short int
      48
      49      go to error;
      50
      51/case(t_string)/                 $ short characters
      52
smfb 122      build_spec(lim, t_int, sc_nchars_ a2);      $ get # a2, then
      54      go to loop;
      55
      56
      57
      58/case(t_atom)/                 $ atom
      59
      60/case(t_proc)/
      61
      62/case(t_lab)/
      63
      64      go to error;
      65
      66/case(t_elmt)/            $ base element
      67
      68      deref(a2);
      69      go to switch;
      70
      71
      72/case(t_latom)/               $ long atom
      73
      74/case(t_lint)/                $ long int
      75
      76/case(t_real)/     $ real
      77
      78      go to error;
      79
      80
      81
      82/case(t_istring)/             $ long character string
      83
      84      +*  before(i)  =  heap(t-1+i)  **
stra 226
stra 227      ss2 = value_ a2; len2 = ss_len(ss2);
stra 228
stra 229      if otype_ a1 = t_string then
stra 230          build_spec(lim, t_int, len2);
stra 231          go to loop;
stra 232      end if;
smfb 123
smfb 124      if (otype_ a1 ^= t_istring) go to fail;
      85
      86      ss1 = value_ a1;   len1 = ss_len(ss1);
      88
      89      if (len1 > len2) go to fail;
      90$
      91$ build the 'before' map for a1
      92$
      93      get_stack(len1);        $ get space for the 'before' map
      94      j1 = 0;
      95      do j2 = 1 to len1;
      96          while j1 > 0 & icchar(ss1, j1) ^= icchar(ss1, j2);
      97              j1 = before(j1);
      98          end while;
      99          before(j2) = j1; j1 = j1 + 1;
     100      end do;
     101$
smfb 125$ then do comparison
     103$
     104      member = no;            $ assume no match
     105      j1 = 0;
     106      do j2 = 1 to len2;
     107          while j1 > 0 & icchar(ss1, j1+1) ^= icchar(ss2, j2);
     108              j1 = before(j1);
     109          end while;
     110          if (icchar(ss1, j1+1) = icchar(ss2, j2)) j1 = j1 + 1;
     111          if j1 >= len1 then member = yes; quit do j2; end if;
     112      end do;
     113      free_stack(len1);       $ release storage for the 'before' map
smfb 126
     114      macdrop(before);
     115
     116      return;
     117
     118
     119/case(t_tuple)/               $ tuples
     120
     121/case(t_stuple)/
     122
     123$ the nelt of tuples is always valid. this is quite handy here.
     124
     125      build_spec(lim, t_int, nelt(value_ a2));
     126      go to loop;
     127
     128
     129
     130/case(t_set)/        $ sets and maps
     131
     132/case(t_map)/
     133
     134      member = memset(a1, a2);
     135      return;
     136
     137
     138
     139
     140case_om;        $ om types
     141
     142      call err_om(4);
     143
     144      member = no;
     145
     146      return;
     147
     148/error/         $ illegal type for a2
     149
     150      call err_type(19);
     151
     152      member = no;
     153
     154      return;
     155
     156
     157/loop/           $ loop through a2 checking for agr1
     158
     159      indx = one;  $ set index to setl one.
     160
     161      while le(indx, lim);
     162
     163          call of(elmt, a2, indx);    $ get element of a2
     164
     165          if (eq(a1, elmt)) go to pass;
     166          if ^ ne(a1, elmt) then
     167              if (equal(a1, elmt)) go to pass;
     168          end if;
     169
     170          add1(indx);
     171
     172      end while;
     173
     174/fail/
     175
     176      member = no;         $ not found
     177      return;
     178
     179
     180
     181/pass/                 $ found
     182
     183      member = yes;
     184      return;
     185
     186      end fnct member;
       1 .=member memset
       2      fnct memset(elmt, set);
       3
       4$ this function tests set membership. like all
       5$ predicates in the library, it returns 1 or 0, rather than setl
       6$ true or false.
       7
       8$ the routine is iterative rather than recursive.
       9
      10
      11      size memset(1);    $ boolean value returned
      12
      13      size elmt(hs),    $ specifiers for arguments
      14           set(hs);
      15
      16      size st(hs),     $ local copies of arguments
      17           el(hs);
      18
      19      size s(ps),   $ pointer to set
      20           pos(ps);     $ pointer returned by locate
      21
      22      size hd(hs),    $ components of pair
      23           tl(hs),
      24           im(hs);     $ current image of hd.
      25
      26
      27      size equal(1),  $ functions called
      28           fval(hs);
      29
      30
      31      st = set;             $ make local copies of arguments
      32      el = elmt;
      33
      34
      35/entry/   $ main entry point
      36
      37
      38      s = value_ st;  $ get pointer to set
      39
      40      go to case(htype(s)) in h_uset to h_lrmap;
      41
      42/case(h_uset)/            $ standard set
      43
      44      call locate(pos, el, s, no);
      45      if (^ loc_found) go to nfound;
      46
      47      go to found;
      48
      49
      50/case(h_umap)/           $ unbased map
      51
      52/case(h_lmap)/          $ local map
      53
      54/case(h_rmap)/          $ remote map
      55
      56/case(h_lpmap)/            $ local packed map
      57
      58/case(h_limap)/                $ local integer map
      59
      60/case(h_lrmap)/                $ local real map
      61
      62/case(h_rpmap)/            $ remote packed map
      63
      64/case(h_rimap)/            $ remote real map
      65
      66/case(h_rrmap)/            $ remote real map
      67
      68$ if el is a pair, split it into hd and tl. otherwise
      69$ it cant be an element of a map.
      70
      71      deref(el);
      72
      73      if otype_ el = t_tuple then  $ may be standard pair
      74          if (nelt(value_ el) ^= 2) go to nfound;
      75
      76          hd = tcomp(value_ el, 1);
      77          tl = tcomp(value_ el, 2);
      78
      79      elseif otype_ el = t_stuple then $ may be oddball pair
      80
      81          if (nelt(value_ el) ^= 2) go to nfound;
      82
      83          call of(hd, el, one);
      84          call of(tl, el, two);
      85
      86      else   $ not a pair
      87          go to nfound;
      88      end if;
      89
      90      if (is_om_ hd) go to nfound;   $ el is not a pair
      91      if (is_om_ tl) go to nfound;
      92
      93      call locate(pos, hd, s, no);    $ locate hd in domain
      94      if (^ loc_found) go to nfound;
      95
      96                          $ get image
      97      im = fval(s, pos, no);
      98
      99      if is_multi_ im then      $ image is multivalued. apply membership
     100                              $ test for tl in. image
     101          st = im;
     102          el = tl;
     103
     104          go to entry;
     105
     106      else                     $ image is single valued. compare with tl
     107          if (eq(im, tl)) go to found;
     108          if (ne(im, tl)) go to nfound;
     109          if (equal(im, tl)) go to found;
     110          go to nfound;
     111      end if;
     112
     113
     114/case(h_lset)/              $ local subset
     115
     116/case(h_rset)/              $ remote subset
     117
     118      call locate(pos, el, s, no);
     119
     120      if loc_found then        $ el is in base
     121          if (fval(s, pos, no)) go to found;
     122      end if;
     123
     124      go to nfound;
     125
     126
     127
     128/found/              $ found element. return true.
     129
     130      memset = yes;
     131      return;
     132
     133
     134
     135/nfound/             $ element not found
     136
     137      memset = no;
     138      return;
     139
     140      end fnct memset;
       1 .=member of
       2      subr of(out, f, x);
       3$
       4$ this is the general functional evaluation routine. it performs
       5$ out = f(x), where out, f, and x are specifiers. note that this
       6$ is written as a subroutine since -f- may be modified by converting
       7$ a set to a map.
       8$
       9      size out(hs);           $ specifier returned
      10      size f(hs);             $ specifier for map/tuple/string
      11      size x(hs);             $ specifier for index
      12
      13      size i(hs),      $ integer index
      14           p(ps),      $ pointer to long object
      15           n(ps); $ length of long object
      16
      17      size ss(ssz),   $ original string specifier
      18           ss1(ssz);  $ new string specifier
      19
      20      size val(hs),    $ packed value
      21           newp(ps);    $ pointer to new heap block
      22
      23      size map(ps),  $ pointer to map.
      24           pos(ps); $ pointer to eb
      25
      26
      27      size fval(hs),  $ functions called
      28           convsm(hs),
      29           arb1(hs);
      30
      31
      32/begin/
      33
      34      go to case(otype_ f) in t_min to t_max;
      35
      36
      37/case(t_int)/
      38
      39      go to error1;
      40
      41
      42/case(t_string)/              $ short character string
      43
      44      i = x;   deref(i);   i = otvalue_ i;
      45
      48      if i = 0 ! i > sc_nchars_ f then
stra 233          build_spec(out, t_ostring, 0);
      50      else
stra 234          out = spec_char;  $ one-character template
stra 235          scchar(out, 1) = scchar(f, i);
      52      end if;
      53
      54      return;
      55
      56
      57/case(t_atom)/                 $ short atom
      58
      59/case(t_proc)/
      60
      61/case(t_lab)/
      62
      63/case(t_latom)/              $ long atom
      64
      65/case(t_lint)/               $ long integer
      66
      67      go to error1;
      68
      69
      70/case(t_elmt)/  $ element
      71
      72      deref(f);
      73
      74      go to begin;
      75
      76
      77/case(t_istring)/             $ long character string
      78
      79      i = x;   deref(i);   i = otvalue_ i;
      80
      81      ss = value_ f;
      82      n  = ss_len(ss);
      83
      84      if i = 0 ! i > n then
stra 236          build_spec(out, t_ostring, 0);
      86
      87      else   $ build new string specifier
stra 237          out = spec_char;  $ one-character template
stra 238          scchar(out, 1) = icchar(ss, i);
      90      end if;
      91
      92      return;
      93
      94
      95
      96/case(t_real)/                $ real
      97
      98      go to error1;
      99
     100
     101/case(t_tuple)/               $ standart tuple
     102
     103      i = x;   deref(i);   i = otvalue_ i;
     104      p = value_ f;
     105
     106      if (i > nelt(p)) i = 0;
     107
     108      is_shared_ tcomp(p, i) = yes;
     109      out = tcomp(p, i);
     110
     111      return;
     112
     113
     114/case(t_stuple)/              $ special tuple
     115
     116      i = x;   deref(i);   i = otvalue_ i;
     117      p = value_ f;
     118
     119      if (i > nelt(p)) i = 0;  $ give om result
     120
     121      go to tc(htype(p)) in h_ptuple to h_rtuple;
     122
     123
     124/tc(h_ptuple)/                $ packed tuple
     125
     126      if i = 0 then
     127          val = 0;
     128      else
     129          val = pcomp(p, i);
     130      end if;
     131
     132      unpack(ptkey(p), val, out);
     133
     134      return;
     135
     136
     137/tc(h_ituple)/                $ untyped integer tuple
     138
     139      val = tcomp(p, i);
     140      put_intval(val, out);
     141
     142      return;
     143
     144
     145/tc(h_rtuple)/                $ untyped real tuple
     146
     147      val = tcomp(p ,i);
     148      put_realval(val, out);
     149
     150      return;
     151
     152
     153/case(t_set)/
     154
     155      f = convsm(f, f_umap);
     156
     157      if otype_ f ^= t_map then $ conversion failed
     158          out = err_val(f_gen);
     159          return;
     160      end if;
     161
     162
     163/case(t_map)/                   $ maps
     164
     165      map = value_ f;
     166
     167      call locate(pos, x, map, no);
     168      out = fval(map, pos, yes);
     169
     170$ if the image is stored with its is_multi bit on, it may be a singleton
     171$ set or it may actually be multivalued. we find out which by calling
     172$ arb1, which removes singletons. if the image still has its is_multi
     173$ bit set, then it is actually multivalued, and we abort.
     174
     175      if is_multi_ out then
     176          out = arb1(out);
     177
     178          if is_multi_ out then
     179              call err_misc(29);
     180              out = err_val(f_gen);
     181          end if;
     182      end if;
     183
     184      return;
     185
     186
     187
     188case_om        $ om types
     189
     190      call err_om(32);
     191      go to error;
     192
     193
     194/error1/                      $ applying f(x) to illegal type
     195
     196      call err_type(20);
     197
     198
     199/error/
     200
     201      if isprim(type_ f) then
     202          out = err_val(f_gen);
     203      else
     204          out = err_val(ft_elmt(hform(value_ f)));
     205      end if;
     206
     207
     208      end subr of;
       1 .=member ofa
       2      subr ofa(out, f, x);
       3
       4$ this routine performs out = f<>. it is a subr rather than a fnct
       5$ since it may modify f by converting a set to a map.
       6
       7
smfc  46      size out(hs);           $ specifier returned (wr)
smfc  47      size f(hs);             $ specifier for map (rw)
smfc  48      size x(hs);             $ specifier for index (rd)
smfc  49
smfc  50      size map(ps);           $ pointer to map data block
smfc  51      size pos(ps);           $ pointer returned by locate/insert
smfc  52      size im(hs);            $ specifier for range set
smfc  53      size s(ps);             $ pointer to range set
smfc  54
smfc  55      size convsm(hs);        $ converts set to map
smfc  56      size fval(hs);          $ retrieves map image
smfc  57      size nullset(hs);       $ returns null set
smfc  58      size rset1(hs);         $ builds singleton set
      21
      22
      23$ see if f is a set
      24
      25      deref(f);
      26
      27      if (otype_ f = t_set) f = convsm(f, f_umap);
      28
      29      if otype_ f ^= t_map then
      30          if is_om_ f then
      31              call err_om(33);
      32          else
      33              call err_type(21);
      34          end if;
      35
      36          out = err_val(f_gen);
      37
      38          return;
      39      end if;
      40
      41      map = value_ f;
      42
      43      call locate(pos, x, map, no);
      44      out = fval(map, pos, yes);  $ get image
      45
smfc  59      if is_multi_ out then
smfc  60          is_multi_ out = no;  $ clear before returning
smfc  61
smfc  62      elseif is_smap(map) then
smfc  63          out = rset1(out);  $ build singleton set
smfc  64
smfc  65      else
smfc  66          im = nullset(ft_imset(hform(map)), 1);
smfc  67          if is_om_ out = no then
smfc  68              s = value_ im; call insert(pos, out, s); value_ im = s;
smfc  69          end if;
smfc  70          out = im;
smfc  71      end if;
      48
      49
      50      end subr ofa;
       1 .=member sof
       2      subr sof(f, x, y);
       3$
       4$ this routine performs -f(x) := y-.
       5$
       6$ we assume that f can be used destructively, and that any necessary
       7$ share bits for x and y were set by the caller.
       8$
       9      size f(hs);             $ specifier for map/tuple/string
      10      size x(hs);             $ specifier for index
      11      size y(hs);             $ specifier for value
      12
      13      size x1(hs);            $ local copy of x
      14      size y1(hs);            $ local copy of y
      15
      16      size ss1(ssz);          $ string specifier for f
      17      size ss2(ssz);          $ string specifier for y
      18      size fm(ps);            $ form of object
      19      size n(ps);             $ cardinality of object
      20      size p(ps);             $ pointer to long object
      21      size i(ps);             $ integer index
      22      size val(hs);           $ packed value
smfb 127      size om_val(hs);        $ proper omega for tuple component
      23
      24      size map(ps),    $ pointer to map
      25           pos(ps),    $ pointer returned by locate
      26           yy(hs);   $ copy of y, used in map assignments
      27
      28      size retpt(ps);  $ return pointer for l_call
      29
      30
      31      size rset1(hs),  $ functions called
      32           ssbsts(hs),
      33           convert(hs),
      34           convsm(hs),
      35           copy1(hs);
      36
      37 .=zzyorg a                   $ counter for return labels
      38
      39
      40/begin/    $ begin execution
      41
      42      go to case(otype_ f) in t_min to t_max;
      43
      44/case(t_int)/     $ short integer
      45
      46      go to error1;
      47
      48
      49/case(t_string)/              $ short character string
      50
stra 239      x1 = x;   deref(x1);
stra 240      y1 = y;   deref(y1);
stra 241
stra 242      if (otype_ x1 ^= t_int) go to error4;
stra 243
stra 244      i = ivalue_ x1;
stra 245
stra 246      if ( ^ (1 <= i & i <= sc_nchars_ f)) go to error2;
stra 247
stra 248      if otype_ y1 = t_string then
stra 249          if sc_nchars_ y1 = 1 then
stra 250              scchar(f, i) = scchar(y1, 1);
stra 251          else
stra 252              f = ssbsts(f, x1, x1, y1);
stra 253          end if;
stra 254      elseif otype_ y1 = t_istring then
stra 255          ss2 = value_ y1;
stra 256          if ss_len(ss2) = 1 then
stra 257              scchar(f, i) = icchar(ss2, 1);
stra 258          else
stra 259              f = ssbsts(f, x1, x1, y1);
stra 260          end if;
stra 261      else
stra 262          go to error3;
stra 263      end if;
      58
      59      return;
      60
      61
      62/case(t_atom)/                 $ short atom
      63
      64/case(t_proc)/
      65
      66/case(t_lab)/
      67
      68      go to error1;
      69
      70
      71/case(t_elmt)/          $ base element
      72
      73      deref(f);
      74
      75      go to begin;
      76
      77
      78/case(t_latom)/              $ long atom
      79
      80/case(t_lint)/               $ long integer
      81
      82      go to error1;
      83
      84
      85/case(t_istring)/             $ long character string
      86
      87      x1 = x;   deref(x1);
      88      y1 = y;   deref(y1);
      89
stra 264      if (otype_ x1 ^= t_int) go to error4;
stra 265
stra 266      i = ivalue_ x1;
stra 267      ss1 = value_ f;
stra 268
stra 269      if ( ^ ( 1 <= i & i <= ss_len(ss1))) go to error2;
stra 270
stra 271      if otype_ y1 = t_string then
stra 272          if sc_nchars_ y1 = 1 then
stra 273              f = copy1(f); ss1 = value_ f;  $ always copy long strings
stra 274              icchar(ss1, i) = scchar(y1, 1);
stra 275          else
stra 276              f = ssbsts(f, x1, x1, y1);
stra 277          end if;
stra 278      elseif otype_ y1 = t_istring then
stra 279          ss2 = value_ y1;
stra 280          if ss_len(ss2) = 1 then
stra 281              f = copy1(f); ss1 = value_ f;  $ always copy long strings
stra 282              icchar(ss1, i) = icchar(ss2, 1);
stra 283          else
stra 284              f = ssbsts(f, x1, x1, y1);
stra 285          end if;
stra 286      else
stra 287          go to error3;
stra 288      end if;
     104
     105      return;
     106
     107
     108/case(t_real)/                $ real
     109
     110      go to error1;
     111
     112
     113/case(t_tuple)/                 $ standard tuple
     114
     115      i = x;   deref(i);   i = otvalue_ i;
     116      p = value_ f;
     117
     118$ we begin by doing a preliminary range check against the nelt of the
     119$ tuple (which is always valid). this test catches cases in which we
     120$ are extending the tuple, and in which we are shortening it by
     121$ setting t(?t) = om.
     122
     123      if i = 0 ! i > nelt(p) then l_call(expand_tup); end if;
     124
     125$ if the tuple is a mixed tuple, we must assure that -y- has the
     126$ proper type.
     127
     128      fm = hform(p);
     129
     130      if ft_type(fm) = f_mtuple then
     131          if i > ft_lim(fm) then
     132              call err_misc(42);
     133              go to error;
     134          end if;
     135
     136          fm = mttab(ft_elmt(fm)+i);
     137          y = convert(y, fm);
     138      end if;
     139
     140      tcomp(p, i) = y;
     141
     142      is_hashok(p) = no;  $ invalidate hash
smfb 128
smfb 129      if i = nelt(p) & is_om_ y then
smfb 130          until i = 0;
smfb 131              i = i - 1;
smfb 132              if ( ^ is_om_ tcomp(p, i)) quit until;
smfb 133          end until;
smfb 134          nelt(p) = i;
smfb 135      end if;
     144
     145      return;
     146
     147
     148/case(t_stuple)/            $ special tuple
     149
     150      i = x;   deref(i);   i = otvalue_ i;
     151      p = value_ f;
     152      if i = 0 ! i > nelt(p) then l_call(expand_tup); end if;
     153      is_hashok(p) = no;  $ invalidate hash
     154
     155      go to tc(htype(p)) in h_ptuple to h_rtuple;
     156
     157
     158/tc(h_ptuple)/               $ packed tuple
     159
     160      pack(ptkey(p), val, y);
     161      pcomp(p, i) = val;
smfb 136
smfb 137      if i = nelt(p) & is_om_ y then
smfb 138          until i = 0;
smfb 139              i = i - 1;
smfb 140              if (pcomp(p, i) ^= 0) quit until;
smfb 141          end until;
smfb 142          nelt(p) = i;
smfb 143      end if;
     163
     164      return;
     165
     166
     167/tc(h_ituple)/               $ integer tuple
     168
     169      get_intval(val, y);
     170      tcomp(p, i) = val;
smfb 144
smfb 145      if i = nelt(p) & is_om_ y then
smfb 146          om_val = tcomp(p, 0);
smfb 147          until i = 0;
smfb 148              i = i - 1;
smfb 149              if (tcomp(p, i) ^= om_val) quit until;
smfb 150          end until;
smfb 151          nelt(p) = i;
smfb 152      end if;
     172
     173      return;
     174
     175
     176/tc(h_rtuple)/               $ real tuple
     177
     178      get_realval(val, y);
     179      tcomp(p, i) = val;
smfb 153
smfb 154      if i = nelt(p) & is_om_ y then
smfb 155          om_val = tcomp(p, 0);
smfb 156          until i = 0;
smfb 157              i = i - 1;
smfb 158              if (tcomp(p, i) ^= om_val) quit until;
smfb 159          end until;
smfb 160          nelt(p) = i;
smfb 161      end if;
     181
     182      return;
     183
     184
     185/case(t_set)/                    $ sets require conversion to maps
     186
     187      f = convsm(f, f_umap);
     188
     189      if (otype_ f ^= t_map) go to error;   $ conversion failed
     190
     191
     192/case(t_map)/
     193
     194      map = value_ f;  $ get pointer to map
     195
     196      if is_om_ y & ^ is_based(map) then
     197          $ delete element block
     198          call locate(pos, x, map, no);
     199          if (loc_found) call delete(map, loc_prev, pos, yes);
     200
     201      else      $ store value_ in map.
     202                 $ build singleton set if this is an mmap.
     203          yy = y;
     204
     205          if is_mmap(map) then
     206              yy = rset1(yy);   fm = ft_im(hform(map));
     207              if (hform(value_ yy) ^= fm) yy = convert(yy, fm);
     208              is_multi_ yy = yes;
     209          end if;
     210
     211          call locate(pos, x, map, yes);  $ locate x
     212          call sfval(map, pos, yy);
     213
     214      end if;
     215
     216$ for the moment we invalidate the hash and nelt of the map. it might
     217$ be better to update them, but only experimentation will tell.
     218
     219      is_hashok(map) = no;
     220      is_neltok(map) = no;
     221
     222      value_ f = map;  $ store new map value
     223
     224      return;
     225
     226
     227
     228
     229case_om;          $ om types
     230
     231      call err_om(6);
     232      go to error;
     233
     234
     235/error1/                      $ error returns
     236
     237      call err_type(22);
     238      go to error;
     239
     240
     241/error2/
     242
     243      call err_misc(30);
     244      go to error;
     245
     246
     247/error3/                      $ cannot assign -y- to -f-
     248
     249      call err_type(39);
     250      go to error;
     251
     252
     253/error4/
     254
     255      call err_misc(33);
     256
     257/error/                       $ return proper .om
     258
     259      if isprim(type_ f) then
     260          f = err_val(f_gen);
     261      else
     262          f = err_val(hform(value_ f));
     263      end if;
     264
     265      return;
     266
     267
     268
     269/expand_tup/            $ expand tuple
     270
     271$ this local routine handles sinister assignments to tuples where the
     272$ index is zero, or is greater than or equal to the nelt of the tuple.
     273
     274      if i = 0 then
     275          call err_misc(32);
     276          go to error;
     277      end if;
     278
     279      if i > maxsi then       $ illegal index
     280          if (type_ i = t_lint) call err_fatal(6);
     281
     282          go to error4;
     283      end if;
     284
     285      if i > maxindx(p) then
     286          call exptup(f, i);   p = value_ f;
     287      end if;
     288
     289      if (^ is_om_ y) nelt(p) = i;
     290
     291      go to rlab(retpt) in 1 to zzya;       $ local return
     292
     293      end subr sof;
       1 .=member sofa
       2       subr sofa(f, x, y, decl);
       3$
       4$ this routine performs -f<> := y-.
       5$
       6$ we assume that f can be used destructively, and that any necessary
       7$ share bits for x and y were set by the caller.  -decl- indicates
       8$ that the arguments are declared.
       9$
      10      size f(hs),     $ specifier for map
      11           x(hs),      $ specifier for argument to mapping
      12           y(hs),    $ specifier for rhs of assignment
      13           decl(1);   $ indicates arguments declared
      14
      15      size map(ps),      $ pointer to map
      16           n(ps),      $ nelt of y
      17           pos(ps),      $ pointer returned by locate
      18           yy(hs);   $ copy of y
      19
      20
      21      size arbs(hs),
      22           merge_np(hs),
      23           convsm(hs),
      24           convmm(hs),
      25           copy1(hs);
      26
      27
      28      deref(f);
      29
      30      if (otype_ f = t_set) f = convsm(f, f_umap);
      31
      32      if otype_ f ^= t_map then
      33          if is_om_ f then
      34              call err_om(34);
      35          else
      36              call err_type(23);
      37          end if;
      38
      39          f = err_val(f_gen);
      40          return;
      41      end if;
      42
      43      if ^ isset(otype_ y) then
      44          call err_type(24);
      45          f = err_val(f_gen);
      46          return;
      47      end if;
      48
      49      map = value_ f;  $ get pointer to map
      50
      51$ take special action if we are storing a null or singleton set.
      52      ok_nelt(y);
      53      n = nelt(value_ y);
      54
      55
      56      if n = 0 & ^ is_based(map) then
      57$ delete eb
      58          call locate(pos, x, map, no);
      59          if (loc_found) call delete(map, loc_prev, pos, yes);
      60
      61      else       $ store image
      62          yy = y;   $ set up image
      63          is_multi_ yy = yes;
      64
      65$ handle special cases. these include sofa on smaps, and sofa where
      66$ y is a null or singleton set.
      67
      68          if n > 1 then
      69              if is_smap(map) then
      70                  if decl then
      71                      $ declared smap becomes multi-valued
      72                      call err_misc(34);
      73                      f = err_val(hform(map));
      74
      75                  else
      76                      f   = convsm(f, f_umap);
      77                      map = value_ f;
      78                  end if;
      79              end if;
      80
      81          else  $ yy is null or a singleton
      82              if (^ is_mmap(map)) yy = arbs(yy);
      83          end if;
      84
      85          call locate(pos, x, map, yes);   $ locate x in domain
      86
      87          call sfval(map, pos, yy);
      88          value_ f = map;   $ store new set value_
      89
      90      end if;
      91
      92      is_hashok(map) = no;  $ invalidate nelt and hash
      93      is_neltok(map) = no;
      94
      95
      96      end subr sofa;
       1 .=member fval
       2      fnct fval(map, eb, share);
       3
       4$ this is a very low level routine for retrieving map images.
       5$ it is called after we have already found the coorresponding
       6$ domain element in the hash table of the map. fval is never
       7$ called from outside the library, but rather from routines
       8$ such as 'of' and 'equal'. fval can also be applied to based sets.
       9$ in this case it returns zero or one depending on whether the
      10$ elements is in the set. fvals arguments are:
      11
      12$ map: a pointer to the map.
      13$ eb:  a pointer to the eb containing the functional information
      14$ share: flag indicating whether we should set is_shared
      15$       bit of map element.
      16
      17$ the returned value is a specifier with its is_multi bit
      18$ appropriately set.
      19
      20
      21      size fval(hs);     $ specifier returned
      22
      23      size map(ps),     $ pointer to map
      24           eb(ps),      $ pointer to eb of map
      25           share(1);     $ indicates that share bit should be set
      26
      27      size org(ps),     $ first bit position in local packed map
      28           off(ps),     $ word offset
      29           len(ps);           $ length of packed value
      30
      31      size val(hs),    $ untyped value
      32           p(ps),      $ pointer to new heap block
      33           i(ps);          $ ebindx for remote maps and sets
      34
      35
      36      go to case(htype(map)) in h_uset to h_lrmap;
      37
      38
      39/case(h_uset)/      $ unbased set
      40
      41$ we should never reach here
      42
      43      call err_fatal(7);
      44
      45
      46/case(h_umap)/
      47$ standard map.
      48
      49      if (share) is_shared_ ebimag(eb) = yes;
      50      fval = ebimag(eb);
      51
      52      return;
      53
      54
      55
      56/case(h_lmap)/
      57$ local map
      58
      59      if (share) is_shared(eb+ls_word(map)) = yes;
      60      fval = heap(eb+ls_word(map));
      61
      62      return;
      63
      64
      65/case(h_lpmap)/
      66$ local packed map
      67
      68      org = ls_bit(map);
      69      off = ls_word(map);
      70      len = ls_bits(map);
      71
      72      val = .f. org, len, heap(eb+off);
      73
      74      unpack(ls_key(map), val, fval);
      75
      76      return;
      77
      78
      79/case(h_limap)/             $ local integer map
      80
      81      val = heap(eb+ls_word(map));
      82      put_intval(val, fval);
      83
      84      return;
      85
      86
      87/case(h_lrmap)/       $ local real map
      88
      89      val = heap(eb+ls_word(map));
      90      put_realval(val, fval);
      91
      92      return;
      93
      94
      95/case(h_lset)/     $ local set
      96
      97$ for based sets, fval returns zero or one, indicating whether the
      98$ elements membership bit is on.
      99
     100      fval = .f. ls_bit(map), 1, heap(eb+ls_word(map));
     101      return;
     102
     103
     104
     105/case(h_rmap)/
     106$ remote map.
     107
     108      i = ebindx(eb);
     109      if (i > maxindx(map + hl_rmap)) i = 0;
     110
     111      if (share) is_shared_ tcomp(map + hl_rmap, i) = yes;
     112      fval = tcomp(map + hl_rmap, i);
     113
     114      return;
     115
     116
     117
     118/case(h_rpmap)/               $ packed remote smap
     119
     120      i = ebindx(eb);
     121
     122      if i > maxindx(map + hl_rpmap) then
     123          val = 0;
     124      else
     125          val = pcomp(map + hl_rpmap, i);
     126      end if;
     127
     128      unpack(ptkey(map+hl_rpmap), val, fval);
     129
     130      return;
     131
     132
     133/case(h_rimap)/
     134$ remote integer smap
     135
     136      i = ebindx(eb);
     137      if (i > maxindx(map + hl_rmap)) i = 0;
     138
     139      val = tcomp(map + hl_rmap, i);
     140      put_intval(val, fval);
     141
     142      return;
     143
     144
     145
     146/case(h_rrmap)/
     147$ remote real smap
     148
     149$ similar to remote integer map, above
     150
     151      i = ebindx(eb);
     152      if (i > maxindx(map + hl_rmap)) i = 0;
     153
     154      val = tcomp(map + hl_rmap, i);
     155      put_realval(val, fval);
     156
     157      return;
     158
     159
     160
     161/case(h_rset)/   $ remote set
     162
     163$ return the elements membership bit.
     164
     165$ get index, see if in range
     166
     167      i = ebindx(eb);
     168
     169      if i <= rs_maxi(map) then
     170          fval = rsbit(map, i);
     171      else
     172                           $ om, return no
     173          fval = no;
     174      end if;
     175
     176      return;
     177
     178      end fnct fval;
       1 .=member sfval
       2      subr sfval(map, eb, val);
       3
       4$ this is a very low level routine for functional storage. it assumes
       5$ that we have already located the corresponding domain element in
       6$ the hash table of the map. sfval is also used to set the membership
       7$ bits of based maps. its arguments are:
       8
       9$ map:  pointer to the map
      10$ eb:   pointer to element block for domain element
      11$ val:  specifier for value being stored, with is_multi bit
      12$       properly set.
      13
      14
      15      size map(ps),    $ pointer to map
      16           eb(ps),      $ pointer to proper eb.
      17           val(hs);     $ specifier for value to be stored
      18
      19      size org(ps),     $ bit origin in local packed map
      20           off(ps),   $ word offset
      21           len(ps),     $ length of packed value
      22           pval(hs);      $ packed value
      23
      24      size i(ps);     $ ebindx for remote maps and sets
      25
      26      size nwords(ps);     $ length of bit string for remote set
      27
      28      size exprmap(ps),  $ functions called
      29           exprset(ps);
      30
      31
      32      go to case(htype(map)) in h_uset to h_lrmap;
      33
      34
      35/case(h_uset)/     $ unbased set
      36
      37$ should never reach here
      38
      39      call err_fatal(8);
      40
      41
      42/case(h_umap)/              $ standard map
      43
      44      ebimag(eb) = val;
      45      return;
      46
      47
      48
      49/case(h_lmap)/             $ local map
      50
      51      heap(eb+ls_word(map)) = val;
      52      return;
      53
      54
      55
      56/case(h_lpmap)/               $ packed local map
      57
      58      org = ls_bit(map);
      59      off = ls_word(map);
      60      len = ls_bits(map);
      61
      62                        $ form packed value
      63      pack(ls_key(map), pval, val);
      64
      65      .f. org, len, heap(eb+off) = pval;
      66
      67      return;
      68
      69
      70
      71/case(h_limap)/          $ local integer map
      72
      73      if is_om_ val then  $ store om_int
      74          heap(eb+ls_word(map)) = om_int;
      75
      76      elseif type_ val = t_int then  $ short integer
      77          heap(eb+ls_word(map)) = ivalue_ val;
      78
      79      else   $ long int
      80          if (liwords(value_ val) > 1) call err_fatal(9);
      81          heap(eb+ls_word(map)) = liword(value_ val, 1);
      82      end if;
      83
      84      return;
      85
      86
      87/case(h_lrmap)/        $ local real map
      88
      89      heap(eb+ls_word(map)) = rval(value_ val);
      90
      91      return;
      92
      93
      94/case(h_lset)/           $ local subset
      95
      96      .f. ls_bit(map), 1, heap(eb + ls_word(map)) = val;
      97
      98      return;
      99
     100
     101/case(h_rmap)/              $ remote map
     102
     103      i = ebindx(eb);
     104
     105      if (i > maxindx(map + hl_rmap)) map = exprmap(map, i);
     106      tcomp(map + hl_rmap, i) = val;
     107
     108      return;
     109
     110/case(h_rpmap)/               $ packed remote smap
     111
     112      i = ebindx(eb);
     113
     114      if (i > maxindx(map + hl_rpmap)) map = exprmap(map, i);
     115
     116      pack(ptkey(map + hl_rpmap), pval, val);
     117
     118      pcomp(map + hl_rpmap, i) = pval;
     119      return;
     120
     121/case(h_rimap)/                $ remote integer map
     122
     123      i = ebindx(eb);
     124
     125      if (i > maxindx(map + hl_rmap)) map = exprmap(map, i);
     126
     127                        $ we assume that val is no longer than 1 word
     128
     129      if is_om_ val then  $ store om_int
     130          tcomp(map + hl_rmap, i) = om_int;
     131
     132      elseif type_ val = t_int then  $ short int
     133          tcomp(map + hl_rmap, i) = ivalue_ val;
     134
     135      else  $ long int
     136          if (liwords(value_ val) > 1) call err_fatal(10);
     137          tcomp(map + hl_rmap, i) = liword(value_ val, 1);
     138      end if;
     139
     140      return;
     141
     142
     143/case(h_rrmap)/                $ remote real map
     144
     145      i = ebindx(eb);
     146
     147      if (i > maxindx(map + hl_rmap)) map = exprmap(map, i);
     148
     149      if is_om_ val then  $ store om_real
     150          tcomp(map + hl_rmap, i) = om_real;
     151
     152      else         $ store real value
     153          tcomp(map + hl_rmap, i) = rval(value_ val);
     154      end if;
     155
     156      return;
     157
     158
     159
     160
     161
     162/case(h_rset)/             $ remote subset
     163
     164      i = ebindx(eb);   $ get index to bit string
     165
     166$ extend bit string if necessary
     167     if (i > rs_maxi(map)) map = exprset(map, i);
     168
     169      rsbit(map, i) = val;
     170
     171      return;
     172
     173
     174      end subr sfval;
       1 .=member next
       2      subr next(val, iter, arg);
       3
       4$ this is the top level routine for iterating over sets and
       5$ tuples. tuple iteration is quite simple, and is handled
       6$ inline, while set and map iteration are handled by a seperate
       7$ routine.
       8
       9$ the arguments to the routine are:
      10
      11$ val:      the value of the previous set or tuple element
      12$ iter:     the previous element in 'iterator format'
      13$ arg:      the set, map, or tuple being iterated over.
      14
      15$ iterator formats for sets and maps are described in the
      16$ routine 'nexts'. iterators for tuples are simply short integers
      17$ giving the index of the previous element.
      18
      19
      20      size val(hs);           $ iteration value
      21      size iter(hs);          $ pointer to iteration value
      22      size arg(hs);           $ specifier for string, tuple, set, or map
      23
      24      size p(ps);             $ pointer to long value
      25      size p1(ps);            $ pointer to new string
      26
      27
      31      p = value_ arg;  $ get pointer to set, tuple, etc.
      32
      33      go to case(otype_ arg) in t_min to t_max;
      34
      35
      36/case(t_int)/    $ error types
      37
      40/case(t_atom)/
      41
      42/case(t_proc)/
      43
      44/case(t_lab)/
      45
      46/case(t_latom)/
      47
      48/case(t_elmt)/
      49
      50/case(t_lint)/
      51
      52/case(t_real)/
      53
      54      call err_type(25);
      55
      56      val = err_val(f_gen);
      57      iter = err_val(f_gen);
      58
      59      return;
stra 289
stra 290
stra 291/case(t_string)/              $ short character string
stra 292
stra 293      add1(iter);
stra 294
stra 295      if value_ iter > sc_nchars_ arg then
stra 296          is_om_ iter = yes;
stra 297          is_om_ val  = yes;
stra 298      else
stra 299          val = arg;  $ since sc_max = 1
stra 300      end if;
stra 301
stra 302      return;
      60
      61
      62/case(t_istring)/
      63
      64      add1(iter);
      65
      66      if value_ iter > ss_len(p) then
      67          is_om_ iter = yes;
      68          is_om_ val  = yes;
      69
      70      else
stra 303          val = spec_char;  $ one-character template
stra 304          scchar(val, 1) = icchar(p, value_ iter);
      73      end if;
      74
      75      return;
      76
      77
      78/case(t_tuple)/   $ tuples
      79
      80      add1(iter);   $ increment index and compare with nelt.
      81
      82      if value_ iter > nelt(p) then
      83          is_om_ val = yes;
      84          is_om_ iter = yes;
      85
      86      else
      87          is_shared_ tcomp(p, value_ iter) = yes;
      88          val = tcomp(p, value_ iter);
      89      end if;
      90
      91      return;
      92
      93/case(t_stuple)/
      94
      95      add1(iter);
      96
      97      if value_ iter > nelt(p) then
      98          is_om_ val = yes;
      99          is_om_ iter = yes;
     100
     101      else
     102          call of(val, arg, iter);
     103      end if;
     104
     105      return;
     106
     107/case(t_set)/    $ sets
     108
     109/case(t_map)/     $ maps
     110
     111      call nexts(val, iter, arg);
     112
     113      return;
     114
     115case_om;   $ om argument type
     116
     117      call err_om(7);
     118
     119      val = err_val(f_gen);
     120      iter = err_val(f_gen);
     121
     122      return;
     123
     124      end subr next;
       1 .=member nexts
       2      subr nexts(valu, itera, set);
       3
       4$ this routine performs iteration over sets and maps. it is
       5$ recursive in order to handle multivalued maps.
       6
       7$ the arguments to the routine are:
       8
       9$ valu:      the value of the previous set element
      10$ itera:     the previous element in 'iterator' format.
      11$ set:       specifier for the set being iterated over.
      12
      13$ iterator format is a special way of representing elements
      14$ of sets, maps, and tuples which allows us to find the
      15$ next element.
      16
      17$ a set iterator has:
      18
      19$ type:     t_elmt
      20$ value:    pointer to eb of current element
      21
      22$ note that for based sets, the representation of an iterator
      23$ is the same as the representation for the elements of the set.
      24
      25$ a map iterator has:
      26
      27$ type:     t_tuple
      28$ value:    pointer to standard pair
      29
      30$ the contents of the pair depend on whether we are currently at
      31$ a multivalued point in the map. if so, then we must get the
      32$ next element by advancing through the image of the current
      33$ domain element; otherwise we must advance through the domain.
      34
      35$ if we are at a multivalued point the pair has:
      36
      37$ is_range:      on to indicated advancing through range
      38$ pair(1):       set iterator for domain of map
      39$ pair(2):       set or map iterator for range set
      40
      41$ otherwise the pair has:
      42
      43$ is_range:      off
      44$ pair(1):       set iterator for domain
      45$ pair(2):       image of domain element
      46
      47$ iteration over a set is quite simple. iteration over a map
      48$ is more complex, and consists of five steps:
      49
      50$ 1. copy the iterator if it is shared since we will modify at least
      51$    one of its components.
      52
      53$ 2. see if the current iterator is a pair  where y is an
      54$    element of the range set f<>. if so, advance y in the range set.
      55
      56$ 3. if we have reached the end of the range set, or if the current
      57$    iterator is the pair  then we must advance in the domain
      58$    of the map until we find another point where the map is defined.
      59
      60$ 4. once we find this new point xx in the domain, we must see if its
      61$    image is multivalued. if so, we initialize an iterator over this
      62$    new range set and advance it.
      63
      64$ 5. finally we rebuild the pair.
      65
      66
      67$ variable declarations
      68
      69
      70$ actual arguments
      71
      72      size valu(hs),  $ previous element value
      73           itera(hs),    $ prevoius iterator returned by next
      74           set(hs);    $ specifier for set we are iterating over
      75
      76$ arguments to recursive part of routine
      77
      78      size val(hs),  $ previous element
      79           iter(hs), $ iterator
      80           st(hs);   $ specifier for set
      81
      82      size tstart(ps);  $ recursion stack pointer at start of routine
      83
      84      size im(hs);  $ map image at cuurent point in domain
      85
      86      size s(ps),   $ pointer to set
      87           spec(hs);  $ temporary specifier
      88      size fm(ps);   $ form of map
      89
      90      size bit(ps),    $ ls_bit of local set
      91           word(ps),    $ ls_bit of local set
      92           indx(ps);    $ ebindx of remote set
      93
      94
      95      size copy1(hs),   $ functions called
      96           fval(hs),
      97           nullp(1);
      98
      99$ stacked variables
     100
     101 .=zzyorg b $ reset counters for stack offsets
     102
     103      local(retpt);      $ return pointer
     104      local(map);       $ pointer to map we are iterating over
     105      local(vpair);   $ pointer to pair for map element value
     106      local(ipair);    $ pointer to pair for map iterator
     107      local(pos);    $ current position in domain
     108
     109      local(p);     $ pointer to range set
     110
     111
     112
     113/begin/             $ begin execution
     114
     115      tstart = t;         $ save initial recursion stack pointer
     116
     117 .=zzyorg a    $ reset counter for return labels
     118
     119      val = valu;  $ make local copies of arguments
     120      iter = itera;
     121      st = set;
     122
     123/entry/          $ recursive entry point
     124
     125      r_entry;   $ increment recursion stack
     126
     127      s = value_ st;   $ get pointer to set
     128
     129      if (^ is_map(s)) go to case_set;  $ branch to set case
     130
     131/case_map/                $ map cases
     132
     133      map = s;   $ save through recursion
     134
     135$ copy val if it is shared. there is no need to copy iter since it
     136$ is never used by anyone other than the next routine.
     137      maycopy(val);
     138
     139$ get pointer to pairs for both val and iter, then get current
     140$ domain position
     141
     142      vpair = value_ val;
     143      ipair = value_ iter;
     144
     145      pos = value_ tcomp(ipair, 1);
     146
     147      if is_range(ipair) then   $ advance in range set
     148
     149          val = tcomp(vpair, 2);
     150          iter = tcomp(ipair, 2); $ get range iterator
     151          st = fval(map, pos, no);
     152
     153          r_call;
     154
     155$ if the returned value is non-om then rebuild 'val' and 'iter'
     156$ and return.
     157          if ^ is_om_ val then
     158              tcomp(vpair, 2) = val;
     159              tcomp(ipair, 2) = iter;
     160
     161              build_spec(val, t_tuple, vpair);
     162              build_spec(iter, t_tuple, ipair);
     163
     164              go to exit;
     165          end if;
     166
     167      end if;
     168
     169
     170$ advance in domain
     171
     172$ advance in domain, skipping elements whose images are om.
     173$ in mmaps we must also skip images which are null sets.
     174
     175$ note that -pos- still points to the current domain element
     176      while 1;
     177          pos = eblink(pos);   $ advance
     178
     179          if is_ebhedr(pos) then  $ skip hash table header blocks
     180              if (is_ebtemp(pos)) quit;
     181              cont;
     182          end if;
     183
     184          im = fval(map, pos, yes);      $ get image
     185
     186          if is_mmap(map) then  $ look for non-null range set
     187              p = value_ im;
     188
     189              if is_neltok(p) then
     190                  if (nelt(p) ^= 0) quit;
     191              else
     192                  if (^ nullp(p)) quit;
     193              end if;
     194
     195          else   $ look for defined image
     196              if (^ is_om_ im) quit;
     197          end if;
     198
     199      end while;
     200
     201$ found new domain element
     202
     203$ if we have reached the end of the domain then we return:
     204
     205$ val:       standard omega for element type of map
     206$ iter:      spec_om
     207
     208
     209      if is_ebtemp(pos) then
     210          fm  = ft_elmt(hform(map));
     211          val = heap(ft_samp(fm));
     212
     213          iter = spec_om;
     214
     215          go to exit;
     216      end if;
     217
     218
     219$ start new range iteration if necessary
     220
     221$ n.b. if -im- is multivalued it can never be a null range set
     222$      (since we skip them in the above loop).
     223
     224      if is_multi_ im then    $ start range iteration
     225          call inext(val, iter, im);
     226          st = im;
     227
     228          r_call;             $ advance in new range set
     229
     230          tcomp(vpair, 2) = val;
     231          tcomp(ipair, 2) = iter; $ store result
     232          is_range(ipair) = yes;
     233
     234      else
     235          tcomp(vpair, 2) = im; $ store image in vpair and iair
     236          tcomp(ipair, 2) = im;
     237          is_range(ipair) = no; $ indicate there is no range set
     238      end if;
     239
     240
     241$ store next domain element
     242
     243$ n.b. the first component of -vpair- will either be a pointer
     244$      pointer to -pos- or its eb specifier, depending on whether
     245$      -map- is based.  however the first component of -ipair- is
     246$      always a pointer.
     247
     248      if is_based(map) then
     249          build_spec(spec, t_elmt, pos);
     250          tcomp(vpair, 1) = spec;
     251      else
     252          is_shared_ ebspec(pos) = yes;
     253          tcomp(vpair, 1) = ebspec(pos);
     254      end if;
     255
     256      build_spec(spec, t_elmt, pos);
     257      tcomp(ipair, 1) = spec;
     258
     259
     260$ build specifier for result
     261
     262      build_spec(val, t_tuple, vpair);
     263      build_spec(iter, t_tuple, ipair);
     264
     265      go to exit;
     266
     267
     268
     269
     270
     271/case_set/             $ set cases
     272
     273      s = value_ st;
     274      pos = value_ iter;    $ get current position in set
     275
     276      go to sc(htype(s)) in h_uset to h_rset;  $ jump on type
     277
     278
     279/sc(h_uset)/       $ unbased set
     280
     281      while 1;    $ advance to next defined element
     282          pos = eblink(pos);    $ advance
     283
     284          if (^ is_ebhedr(pos)) quit;
     285          if (is_ebtemp(pos)) quit;
     286      end while;
     287
     288      go to done;
     289
     290
     291
     292/sc(h_lset)/         $ local based set
     293
     294$ find next element of base with membership bit on.
     295
     296      bit = ls_bit(s);   $ get bit and word offset
     297      word = ls_word(s);
     298
     299      while 1;
     300          pos = eblink(pos);      $ advance
     301
     302          if is_ebhedr(pos) then
     303              if (is_ebtemp(pos)) quit;  $ end of set
     304              cont;
     305          end if;
     306
     307          if (.f. bit, 1, heap(pos+word)) quit;  $ in set
     308      end while;
     309
     310      go to done;
     311
     312
     313
     314/sc(h_rset)/          $ remote based set
     315
     316$ advance in base looking for next element with membership bit on.
     317
     318      while 1;
     319          pos = eblink(pos);       $ advance
     320
     321          if is_ebhedr(pos) then
     322              if (is_ebtemp(pos)) quit;  $ end of set
     323              cont;
     324          end if;
     325
     326          indx = ebindx(pos);    $ get base index
     327          if (indx > rs_maxi(s)) cont;  $ out of range
     328
     329          if (rsbit(s, indx)) quit;   $ in set
     330      end while;
     331
     332      go to done;
     333
     334
     335
     336/done/           $ build new set iterator
     337
     338      if is_based(s) then
     339          build_spec(val, t_elmt, pos);
     340
     341      else
     342          is_shared_ ebspec(pos) = yes;
     343          val = ebspec(pos);
     344      end if;
     345
     346      if (is_ebtemp(pos)) is_om_ val = yes;
     347
     348      if is_ebtemp(pos) then
     349          iter = spec_om;
     350      else
     351          build_spec(iter, t_elmt, pos);
     352      end if;
     353
     354
     355
     356/exit/             $ recursive exit
     357
     358      r_exit;   $ pop recursion stack
     359
     360      if t ^= tstart then     $ recursive return
     361          go to rlab(retpt) in 1 to zzya;
     362
     363      else
     364          valu = val;  $ copy results to actual arguments
     365          itera = iter;
     366          return;
     367      end if;
     368
     369
     370
     371$ drop local variables
     372
     373      macdrop4(retpt, map, vpair, ipair);
     374      macdrop2(pos, p);
     375      macdrop(ended);
     376
     377      end subr nexts;
       1 .=member inext
       2      subr inext(val, iter, arg);
       3
       4$ this routine initilaizes set, tuples, and map iterators.
       5$ 'val' is set to the zero-th element of the set, etc. and
       6$ 'iter' is set to point to the zero-th element.
       7
       8
       9      size val(hs);           $ iteration value
      10      size iter(hs);          $ pointer to iteration value
      11      size arg(hs);           $ specifier for string, tuple, set, or map
      12
      13      size p(ps);             $ pointer to long value
      14      size spec(hs);          $ temporary specifier
      15      size vpair(ps);         $ pair for val
      16      size ipair(ps);         $ pair for iter
      17      size tmp(ps);           $ pointer to template
      18
      19      size fval(hs);          $ map image retrieval utility
      20
      21
      22/begin/    $ begin execution
      23
      24
      25
      26      p = value_ arg;  $ get pointer to set, tuple, etc.
      27
      28      go to case(otype_ arg) in t_min to t_max;
      29
      30
      31/case(t_int)/    $ error types
      32
      35/case(t_atom)/
      36
      37/case(t_proc)/
      38
      39/case(t_lab)/
      40
      41/case(t_latom)/
      42
      43/case(t_lint)/
      44
      45/case(t_real)/
      46
      47      call err_type(26);
      48
      49      val = err_val(f_gen);
      50      iter = err_val(f_gen);
      51
      52      return;
      53
      54
      55/case(t_elmt)/    $ element
      56
      57      deref(arg);   go to begin;
      58
      59
stra 305/case(t_string)/              $ short character string
stra 306
      60/case(t_istring)/    $ strings
      61
      62      iter = zero;
stra 307      val  = heap(ft_samp(f_sstring));
      64
      65      return;
      66
      67
      68/case(t_tuple)/               $ standard tuple
      69
      70      val = tcomp(p, 0);
      71      iter = zero;
      72
      73      return;
      74
      75
      76/case(t_stuple)/              $ special tuple
      77
      78      go to tc(htype(p)) in h_ptuple to h_rtuple;
      79
      80
      81/tc(h_ptuple)/                $ packed tuple
      82
      83      unpack(ptkey(p), 0, val);
      84
      85      iter = zero;
      86
      87      return;
      88
      89
      90/tc(h_ituple)/                $ untyped integer tuple
      91
      92      spec = tcomp(p, 0);
      93      put_intval(spec, val);
      94
      95      iter = zero;
      96
      97      return;
      98
      99
     100/tc(h_rtuple)/                $ untyped real tuple
     101
     102      spec = tcomp(p, 0);
     103      put_realval(spec, val);
     104
     105      iter = zero;
     106
     107      return;
     108
     109
     110/case(t_set)/    $ sets
     111
     112      tmp = template(p);
     113
     114      if is_based(p) then
     115          build_spec(val, t_oelmt, tmp);
     116      else
     117          val = ebspec(tmp);
     118      end if;
     119
     120      build_spec(iter, t_elmt, tmp);
     121
     122      return;
     123
     124
     125/case(t_map)/     $ maps
     126
     127      get_pair(vpair);  $ get pairs for val and iter
     128      get_pair(ipair);
     129
     130      build_spec(val, t_tuple, vpair);
     131      build_spec(iter, t_tuple, ipair);
     132
     133      tmp = template(p);
     134
     135$ build components for 'val'.
     136      if is_based(p) then
     137          build_spec(spec, t_elmt, template(p));
     138          tcomp(vpair, 1) = spec;
     139
     140      else
     141          is_shared_ ebspec(tmp) = yes;
     142          tcomp(vpair, 1) = ebspec(tmp);
     143      end if;
     144
     145      tcomp(vpair, 2) = om_image(p);
     146
     147$ build components for 'iter'.
     148      build_spec(spec, t_elmt, tmp);
     149
     150      tcomp(ipair, 1) = spec;
     151      tcomp(ipair, 2) = om_image(p);
     152
     153      is_range(ipair) = no;
     154
     155      return;
     156
     157
     158case_om;
     159
     160      call err_om(8);
     161
     162      val = err_val(f_gen);
     163      iter = err_val(f_gen);
     164
     165      return;
     166
     167
     168      end subr inext;
       1 .=member nextd
       2      subr nextd(val, iter, arg);
       3
       4$ this routine advances a domain iterator over a string, tuple,
       5$ or map.
       6
       7
       8      size val(hs);           $ specifier for previous value
       9      size iter(hs);          $ pointer to iteration value
      10      size arg(hs);           $ specifier for string, tuple, or map
      11
      12      size pos(ps);           $ position in map domain
      13      size map(ps);           $ pointer to map
      14      size im(hs);            $ map image at current point in domain
      15      size p(ps);             $ pointer to range set
      16      size indx(ps);          $ index in string of tuple
      17      size lim(ps);           $ limit for string or tuple iteration
      18
      19      size nullp(1);          $ null set predicate
      20      size fval(hs);          $ map image retrieval utility
      21
      22
      23      go to case(otype_ arg) in t_min to t_max;
      24
      25
      26/case(t_int)/          $ short int
      27
      28      go to error;
      29
      30
      31/case(t_string)/        $ short character strings
      32
      33      lim = sc_nchars_ arg;
      34
      35      go to test;
      36
      37
      38/case(t_atom)/                    $ short atom
      39
      40/case(t_proc)/
      41
      42/case(t_lab)/
      43
      44/case(t_latom)/         $ long atom
      45
      46/case(t_elmt)/         $ element
      47
      48/case(t_lint)/         $ long integers
      49
      50      go to error;
      51
      52
      53/case(t_istring)/       $ long chars
      54
      55      lim = ss_len(value_ arg);
      56      go to test;
      57
      58
      59/case(t_real)/         $ reals
      60
      61      go to error;
      62
      63
      64/case(t_tuple)/         $ tuples
      65
      66/case(t_stuple)/            $ packed tuples
      67
      68      ok_nelt(arg);
      69      lim = nelt(value_ arg);
      70
      71      go to test;
      72
      73
      74/case(t_set)/          $ sets
      75
      76      go to error;
      77
      78
      79/case(t_map)/           $ standard maps
      80
      81$ get pointer to map and position in domain
      82      map = value_ arg;
      83      pos = value_ iter;
      84
      85      while 1;   $ advance in domain
      86          pos = eblink(pos);
      87
      88          if is_ebhedr(pos) then
      89              if (is_ebtemp(pos)) quit;  $ end of map
      90              cont;
      91          end if;
      92
      93          im = fval(map, pos, no);  $ get image
      94
      95$ skip points where image is om or null
      96          if is_mmap(map) then  $ skip null range sets
      97              p = value_ im;
      98
      99              if is_neltok(p) then
     100                  if (nelt(p) ^= 0) quit;
     101              else
     102                  if (^ nullp(p)) quit;
     103              end if;
     104
     105          else  $ skip om images
     106              if (^ is_om_ im)quit;
     107          end if;
     108
     109      end while;
     110
     111      if is_based(map) then
     112          build_spec(val, t_elmt, pos);
     113      else
     114          is_shared_ ebspec(pos) = yes;
     115          val = ebspec(pos);
     116      end if;
     117
     118      if (is_ebtemp(pos)) is_om_ val = yes;
     119
     120      build_spec(iter, t_elmt, pos);
     121      if (is_ebtemp(pos)) is_om_ iter = yes;  $ flag end of set
     122
     123      return;
     124
     125
     126
     127/test/           $ test for end of tuple or string iteration
     128
     129      add1(iter);  $ increment and check against limit
     130      if (value_ iter > lim) is_om_ iter = yes;
     131
     132      val = iter;  $ copy into val.
     133
     134      return;
     135
     136
     137case_om;            $ om types
     138
     139      call err_om(9);
     140
     141      val = err_val(f_gen);
     142      iter = err_val(f_gen);
     143
     144      return;
     145
     146
     147/error/       $ illegal type for arg
     148
     149      call err_type(27);
     150
     151      val = err_val(f_gen);
     152      iter = err_val(f_gen);
     153
     154      return;
     155
     156
     157      end subr nextd;
       1 .=member inextd
       2      subr inextd(val, iter, arg);
       3
       4$ this routine initializes domain iterators.
       5$ 'val' is set to the zero-th element of the set, etc. and
       6$ 'iter' is set to point to the zero-th element.
       7
       8
       9      size val(hs);           $ iteration value
      10      size iter(hs);          $ pointer to iteration value
      11      size arg(hs);           $ specifier for string, tuple, or map
      12
      13      size p(ps);             $ pointer to long value
      14      size vpair(ps);         $ pointer to value pair
      15      size ipair(ps);         $ pointer to iterator pair
      16      size spec(hs);          $ temporary specifier
      17      size tmp(ps);           $ pointer to template
      18
      19      size convsm(hs);         $ converts set to map
      20
      21
      22/begin/    $ begin execution
      23
      24
      25      p = value_ arg;  $ get pointer to set, tuple, etc.
      26
      27      go to case(otype_ arg) in t_min to t_max;
      28
      29
      30/case(t_int)/    $ error types
      31
      34/case(t_atom)/
      35
      36/case(t_proc)/
      37
      38/case(t_lab)/
      39
      40/case(t_latom)/
      41
      42/case(t_lint)/
      43
      44/case(t_real)/
      45
      46      call err_type(28);
      47
      48      go to error;
      49
      50
      51/case(t_elmt)/   $ element
      52
      53      deref(arg);   go to begin;
      54
      55
stra 308/case(t_string)/              $ short character string
stra 309
      56/case(t_istring)/
      57
      58/case(t_tuple)/   $ tuples
      59
      60/case(t_stuple)/
      61
      62      iter = zero;
      63      val  = zero;
      64
      65      return;
      66
      67
      68/case(t_set)/    $ sets
      69
      70      arg = convsm(arg, f_umap);
      71      if (otype_ arg ^= t_map) go to error; $ conversion failed
      72
      73
      74/case(t_map)/     $ maps
      75
      76      p = value_ arg;
      77      tmp = template(p);
      78
      79      if is_based(p) then
      80          build_spec(val, t_elmt, tmp);
      81      else
      82          is_shared_ ebspec(tmp) = yes;
      83          val = ebspec(tmp);
      84      end if;
      85
      86      build_spec(iter, t_elmt, tmp);
      87
      88      return;
      89
      90
      91case_om;   $ om argument type
      92
      93      call err_om(10);
      94
      95
      96/error/
      97
      98      val = err_val(f_gen);
      99      iter = err_val(f_gen);
     100
     101      return;
     102
     103
     104      end subr inextd;
       1 .=member intro2
       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$                ll          iiiiiiiiii  bbbbbbbbb
      15$                ll          iiiiiiiiii  bbbbbbbbbb
      16$                ll              ii      bb      bb
      17$                ll              ii      bb      bb
      18$                ll              ii      bbbbbbbbb
      19$                ll              ii      bbbbbbbbb
      20$                ll              ii      bb      bb
      21$                ll              ii      bb      bb
      22$                llllllllll  iiiiiiiiii  bbbbbbbbbb
      23$                llllllllll  iiiiiiiiii  bbbbbbbbb
      24$
      25$
      26$       t h e    s e t l    r u n    t i m e    l i b r a r y
      27$
      28$                         p a r t    t w o
      29$
      30$
      31$       this software is part of the setl programming system
      32$                address queries and comments to
      33$
      34$                          setl project
      35$                 department of computer science
      36$                      new york university
      37$           courant institute of mathematical sciences
      38$                       251 mercer street
      39$                      new york, ny  10012
      40$
       1 .=member open
       2      fnct sopen(na);
       3
       4$ this is the setl 'open' routine. we map the arguments into
       5$ a little file identifier and file mode, then call the
       6$ little file statement.
       7
       8      size na(ps);            $ number of arguments on stack
       9
      10      size sopen(hs);         $ returned value
      11
      12      size name(hs);          $ file name
      13      size mode(hs);          $ mode name
      14      size id(ps);            $ file identifier
      15      size str(sds_sz);       $ file name as sds
      16      size acs(ps);           $ access code
      17      size rc(hs);            $ return code for eretsio
      18
      19      size bldsds(sds_sz);    $ converts string to sds
      20      size file_id(ps);       $ looks up file id
      21      size file_mode(ps);     $ looks up file mode
      22
      23
      24      name = stack_arg(1, na);
      25      mode = stack_arg(2, na);
      26
      27      id  = file_id(name, io_open);
      28      acs = file_mode(mode);
      29
      30      str = bldsds(name);
      31      sopen = heap(s_false); $ assume open will fail
      32      call eretsio(id, rc, 1); $ set 'quiet' return if error
      33                               $ opening file.
      34      if (rc) return;
      35
      36      go to case(acs) in io_get to io_write;
      37
      38/case(io_get)/
      39
      40      file id title = str, access = get;
      41
      42      endline(id);
      43
      44      go to esac;
      45
      46/case(io_print)/
      47
      48      file id title = str, access = print;
      49      go to esac;
      50
      51
      52/case(io_put)/
      53
      54      file id title = str, access = put;
      55      go to esac;
      56
      57
      58/case(io_read)/
      59
      60      file id title = str, access = read;
      61      go to esac;
      62
      63
      64/case(io_string)/
      65
      66      call err_fatal(11);
      67
      68
      69/case(io_write)/
      70
      71      file id title = str, access = write;
      72      go to esac;
      73
      74
      75
      76/esac/
      77
      78      if filestat(id,access)=0 then $ if could not open
      79          call eretsio(id, rc, 0); $ set for temination if i/o error
      80          id = file_id(name,io_close); $ delete file from maps
      81          return;
      82      end if;
      83      call eretsio(id, rc, 0); $ set for termination if i/o error.
      84      sopen = heap(s_true);
      85
      86
      87
      88      end fnct sopen;
       1 .=member close
       2      fnct sclose(na);
       3
       4$ this is the setl 'close' procedure.
       5
       6      size na(ps);  $ number of interpreter arguments
       7
       8      size sclose(hs);  $ condition code returned
       9
      10      size name(hs),  $ file name
      11           id(ps);  $ file id
      12
      13      size file_id(ps);  $ looks up file id
      14
      15
      16      name = stack_arg(1, na);
      17      id   = file_id(name, io_close);
      18
      19      if (filestat(id, access)) file id access = release;
      20
      21      sclose = spec_om;
      22
      23
      24      end fnct sclose;
       1 .=member print
       2      fnct print(na);
       3
       4$ this is the setl print function.  it simply calls -print1- with
       5$ the proper file number.
       6
       7      size na(ps);  $ number of arguments
       8
       9      size print(hs),  $ value returned
      10           print1(hs),  $ lower level function
      11           file_id(ps);  $ looks up file id
      12
      13      print = print1(out_file, na);
      14
      15
      16      end fnct print;
       1 .=member printa
       2      fnct printa(na);
       3
       4$ this is the setl printa function. it is just like 'print'
       5$ except that we must look up the file number.
       6
       7      size na(ps);   $ number of arguments
       8
       9      size name(hs),  $ file name
      10           id(ps);  $ file id
      11
      12      size printa(hs),  $ value returned
      13           print1(hs),  $ lower level function
      14           file_id(ps);  $ finds file id
      15
      16
      17      name = stack_arg(1, na);
      18
strb  42      until 1;  $ exit when file id has been determined.
strb  43          until 2;  $ exit when not short null string.
strb  44              if (otype_ name ^= t_string) quit until 2;
strb  45              if (sc_nchars_ name ^= 0) quit until 2;
strb  46
strb  47              $ nullstring ---> standard output file
strb  48              id = out_file;
strb  49              quit until 1;
strb  50          end until 2;
strb  51          until 2;  $ exit when not long null string.
strb  52              if (otype_ name ^= t_istring) quit until 2;
strb  53              if (ss_len(value_ name) ^= 0) quit until 2;
strb  54
strb  55              $ nullstring ---> standard output file
strb  56              id = out_file;
strb  57              quit until 1;
strb  58          end until 2;
strb  59
strb  60          id = file_id(name, io_put);  $ look-up little file id
strb  61      end until 1;
      25
      26      printa = print1(id, na-1);
      27
      28
      29      end fnct printa;
       1 .=member print1
       2      fnct print1(id, na);
       3
       4$ this routine is called from 'print' and 'printa' once the
       5$ number of the output file has been determined. we iterate
       6$ over the items to be printed, calling print2 to print each one.
       7
       8      size id(ps),  $ file id
       9           na(ps);  $ number of arguments
      10
      11      size print1(hs);  $ valur retuened
      12
      13      size j(ps);  $ loop index
      14
      15      size print2(hs);  $ lower level function
      16
      17$ before we start printing anything we reserve all the space that
      18$ print2 will need. this includes space for recursion and for building
      19$ pairs as it iterates over maps.
      20
      21      reserve(reserve_io);
      22      can_collect = no;
      23
      24      do j = 1 to na;
      25          print1 = print2(id, stack_arg(j, na));
      26      end do;
      27
      28$ start a new line if either
      29
      30$ 1. we are in the middle of a line
      31$ 2. we are printing zero items.
      32
      33      if (filestat(id, column) ^= 1 ! na = 0) put id, skip;
      34
      35      can_collect = yes;  $ reenable garbage collection
      36
      37      return;
      38
      39      end fnct print1;
       1 .=member print2
       2      fnct print2(id, a);
       3
       4$ this is the main routine for streamed output. it prints a
       5$ setl value 'a' onto file 'id'.
       6
       7$ print2 is recursive to handle sets and tuples. it assumes that
       8$ the caller has already reserved the maximum space it will need
       9$ for stacked variables, etc. this is necessary so that we do not
      10$ have to backtrack output files after each garbage collection.
      11
asca  17 .+ascebc.
asca  18$ convert strings to ebcdic before output.
asca  19      size ebchar(cs);        $ ascii-to-ebcdic conversion function
asca  20 ..ascebc
      25
      26
      27      size id(ps),  $ file id
      28           a(hs);   $ item to print
      29
      30      size print2(hs);  $ value returned
      31
      32      size arg(hs);  $ copy of a
      33
      34
      35      size tstart(ps); $ initial recursion stack pointer
      36
      37      size val(hs),  $ untyped value
      38           p(ps),  $ misc. pointer
      39           c(cs),             $ character code
      40           i(ps),    $ loop index
      41           j(ps);  $ loop index
      42
      43      size pbits(ps),   $ ptbits of packed tuple
      44           pvect(ps),   $ ptvect of tuple
      45           bpos(ps);    $ bit position in tuple
      46
      47      size ss(ssz);     $ string specifier
      48
      49      size omval(hs);         $ omega value
      50
      51      size tup(ps);  $ pointer to tuple
      52
      53      size t1(hs),   $ temporaries for value return from 'nexts'.
      54           t2(hs);
      55
      56      size rout(sds_sz), $ routine name
      57           stmt(ps);     $ statement number
mjsa  32
mjsa  33      size strli(hs);         $ convert long integer to string
      58
      59$ stacked variables
      60
      61 .=zzyorg b $ reset counters for stack offsets
      62
      63
      64
      65      local(retpt);   $ return pointer
      66
      67      local(temp1);  $ pointer to tuple or specifier for set
      68      local(temp2);  $ index in tuple or element of set
      69      local(temp3);
      70
      71
      72
      73/begin/         $ begin execution
      74
      75      tstart = t;  $ save recursion stack pointer
      76
      77 .=zzyorg a   $ reset counter for return labels
      78
      79      arg = a;
      80
      81/entry/             $ recursive entry point
      82
      83      r_entry;   $ increment recursion stack
      84
      85
      86 /switch/        $ branch on type
      87
      88      go to case(otype_ arg) in t_min to t_max;   $ branch on type
      89
      90
      91
      92
      93/case(t_int)/          $ short integers
      94
      95      put id: ivalue_ arg, i;
      96
      97      go to exit;
      98
      99
     100/case(t_string)/        $ short character strings
     101
     102      do j = 1 to sc_nchars_ arg;
stra 310          c = scchar(arg, j);
stra 311 .+ascebc if (ascebc_flag) c = ebchar(c);  $ convert to ebcdic
     104
     105          put id: c, r(1);
     106      end do;
     107
     108      go to exit;
     109
     110
     111/case(t_atom)/         $ short atom
     112
     113      if arg = heap(s_true) then
     114          put id, '#t';
     115
     116      elseif arg = heap(s_false) then
     117          put id, '#f';
     118
     119      else
     120          put id: 1r#, r(1): ivalue_ arg, i;
     121      end if;
     122
     123      go to exit;
     124
     125
     126/case(t_proc)/   $ procedures
     127
     128/case(t_lab)/    $ labels
     129
     130      call err_fatal(12);
     131
     132
     133/case(t_latom)/     $ long atom
     134
smfa  16      put id ,'#' :la_value(value_ arg),i;
     136
     137      go to exit;
     138
     139
     140/case(t_elmt)/        $ element
     141
     142      deref(arg);    $ get value and try again
     143
     144      go to switch;
     145
     146
     147/case(t_lint)/      $ long integer
     148
mjsa  34      arg = strli(arg);
mjsa  35      $ fall through to string case
     153
     154
     155/case(t_istring)/    $ long character string
     156
     157      ss = value_ arg;  $ get string specifier for argument
     158
     159$ iterate over string printing characters. obviously there-s alot of
     160$ room for loop unrolling here.
     161
     162      do j = 1 to ss_len(ss);
     163          c = icchar(ss, j);
asca  21 .+ascebc if (ascebc_flag) c = ebchar(c);  $ convert to ebcdic
     164
     165          put id: c, r(1);
     166      end do;
     167
     168      go to exit;
     169
     170
     171/case(t_real)/       $ real
     172
     173      put id: rval(value_ arg), e(13, 6);
     174
     175      go to exit;
     176
     177
     178/case(t_tuple)/             $ standard tuple
     179
     180      temp1 = value_ arg;  $ get pointer to tuple
     181      temp2 = 1;  $ component index
     182
     183      put id: ltb_char, r(1), x(1);   $ open tuple
     184
     185      while temp2 <= nelt(temp1);
     186
     187          arg = tcomp(temp1, temp2);
     188          temp2 = temp2+1;
     189
     190          r_call;
     191
     192          put id, x(1);      $ space between components
     193
     194      end while;
     195
     196      put id: rtb_char, r(1);         $ close tuple
     197
     198      go to exit;
     199
     200
     201/case(t_stuple)/          $ special tuple
     202
     203      put id: ltb_char, r(1), x(1);   $ open tuple
     204
     205      tup = value_ arg;
     206
     207      go to tc(htype(tup)) in h_ptuple to h_rtuple;
     208
     209
     210/tc(h_ptuple)/   $ packed tuple
     211
     212      temp1 = value_ arg;     $ get pointer to tuple
     213      temp2 = 1;              $ iteration index
     214
     215      while temp2 <= nelt(temp1);
     216
     217          val = pcomp(temp1, temp2);
     218          unpack(ptkey(temp1), val, arg);
     219
     220          r_call;
     221
     222          put id, x(1);       $ space between components
     223
     224          temp2 = temp2 + 1;
     225
     226      end while;
     227
     228      put id: rtb_char, r(1);         $ close tuple
     229
     230      go to exit;
     231
     232
     233/tc(h_ituple)/       $ integer tuple
     234
     235      omval = tcomp(tup, 0);  $ get omega value
     236
     237      do j = 1 to nelt(tup);
     238          val = tcomp(tup, j);
     239
     240          if val ^= omval then
     241              put id: val, i;
     242          else
     243              put id, '*';
     244          end if;
     245
     246          put id, x(1);
     247      end do;
     248
     249      put id: rtb_char, r(1);         $ close tuple
     250
     251      go to exit;
     252
     253
     254/tc(h_rtuple)/        $ real tuple
     255
     256      omval = tcomp(tup, 0);  $ get omega value
     257
     258      do j = 1 to nelt(tup);
     259          val = tcomp(tup, j);
     260
     261          if val ^= omval then
     262              put id: val, e(13, 6);
     263          else
     264              put id, '*';
     265          end if;
     266
     267          put id, x(1);
     268      end do;
     269
     270      put id: rtb_char, r(1);         $ close tuple
     271
     272      go to exit;
     273
     274
     275/case(t_set)/       $ sets and maps
     276
     277/case(t_map)/
     278
     279$ all sets and maps are printed using the general next routine.
     280
     281      put id: lsb_char, r(1), x(1);   $ open set
     282
     283      temp3 = arg;
     284
     285      call inext(t1, t2, temp3);   $ initialize set iterator
     286      temp1 = t1;
     287      temp2 = t2;
     288
     289      while 1;
     290          t1 = temp1;
     291          t2 = temp2;
     292
     293          call nexts(t1, t2, temp3);  $ advance iterator
     294          temp1 = t1;
     295          temp2 = t2;
     296
     297          if (is_om_ temp1) quit;
     298
     299          arg = temp1;
     300          r_call;
     301
     302          put id, x(1);
     303      end while;
     304
     305      put id: rsb_char, r(1);         $ close set
     306
     307      go to exit;
     308
     309
     310
     311
     312
     313  case_om         $ om types
     314
     315$ isolate errors from omegas
     316
     317      if otype_ arg = t_error then
     318          call find_stmt(rout, stmt, value_ arg);
     319
     320          put id, '*** error at proc: ': rout, a,
     321                     ' stmt: ':          stmt,       i,
     322                     ' addr: ':          value_ arg, i,
     323                  ' ***';
     324      else
     325          put id, '*';
     326      end if;
     327
     328      go to exit;
     329
     330
     331/exit/                $ recursive exit point
     332
     333      r_exit;
     334
     335      if t ^= tstart then   $ recursive return
     336          go to rlab(retpt) in 1 to zzya;
     337      end if;
     338
     339      if (filestat(id, column) ^= 1) put id, x(1);
     340
     341
     342      print2 = spec_om;
     343
     344      return;
     345
     346
     347
     348$ drop local variables
     349
     350      macdrop2(retpt, temp1)
     351      macdrop2(temp2, temp3)
     352
     353
     354      end fnct print2;
       1 .=member readr
       2      fnct readr(na);
       3
       4$ this is the setl read procedure.  it simply calls -read1- with the
       5$ appropriate file number.
       6
       7
       8      size na(ps);            $ number of arguments
       9
      10      size readr(hs);         $ value returned
      11
      12      size read1(hs);         $ lower level routine
      13
      14      access nsread;          $ nameset with static variables
      15
      16
      17      read_file = in_file;
      18      readr     = read1(na);
      19
      20
      21      end fnct readr;
       1 .=member reada
       2      fnct reada(na);
       3
       4$ this is the setl -reada- routine.  it looks up the little file
       5$ identifier and calls -read1-.
       6
       7
       8      size na(ps);            $ number of arguments
       9
      10      size reada(hs);         $ value returned
      11
      12      size name(hs);          $ setl file name
      13
      14      size read1(hs),         $ lower level function
      15           file_id(ps);       $ looks up little file identifier
      16
      17      access nsread;          $ nameset with static variables
      18
      19
      20      if read_case = read_init then $ get little file identifier
      21          name = stack_arg(1, na);
      22
strb  62          until 1;  $ exit when file id has been determined.
strb  63              until 2;  $ exit when not short null string.
strb  64                  if (otype_ name ^= t_string) quit until 2;
strb  65                  if (sc_nchars_ name ^= 0) quit until 2;
strb  66
strb  67                  $ nullstring ---> standard input file
strb  68                  read_file = in_file;
strb  69                  quit until 1;
strb  70              end until 2;
strb  71              until 2;  $ exit when not long null string.
strb  72                  if (otype_ name ^= t_istring) quit until 2;
strb  73                  if (ss_len(value_ name) ^= 0) quit until 2;
strb  74
strb  75                  $ nullstring ---> standard input file
strb  76                  read_file = in_file;
strb  77                  quit until 1;
strb  78              end until 2;
strb  79
strb  80              read_file = file_id(name, io_get);  $ look-up little file
strb  81          end until 1;
      29      end if;
      30
      31      reada = read1(na-1);
      32
      33
      34      end fnct reada;
       1 .=member read1
       2      fnct read1(na);
       3
       4$ this is the setl -read1- routine.  like -getb-, it can be inter-
       5$ rupted for garbage collections.  the variable -read_indx- gives the
       6$ index of the current argument in the argument list.
       7
       8
       9      size na(ps);            $ number of arguments
      10
      11      size read1(hs);         $ value returned
      12
      13      size datum(hs);         $ datum returned by -read2-
      14
      15      size read2(hs);         $ lower level coded read routine
      16
      17      access nsread;
      18
      19
      20      if read_case = read_init then $ initial entry
      21
      22$ make sure no other library routine is currently using the stack,
smfc  72$ since the formatted read routines are the only routines which format
      24$ it correctly.  this check is done by comparing the global stack
      25$ pointer -t- with the global stack pointer on entry of the library,
      26$ -savet-.
      27
      28          if (t ^= savet) call err_fatal(14);
      29
      30$ we keep two local stack pointers:
      31
smfc  73$ read_t1:    stack top an initial entry to formatted read routines
      33
      34$ read_t2:    reference point to update -read_t1- after a garbage
      35$             collection moved the stack.
      36
      37          read_t1 = t;
      38          read_t2 = t;
      39
      40$ initialize the argument index
      41
      42          read_indx = 1;
      43          last_id   = read_file;
      44
      45      else                    $ continue read after garbage collection
      46          read_t1 = read_t1 + (savet - read_t2); $ adjust stack pointer
      47          read_t2 = savet;
      48
      49      end if;
      50
      51      while read_indx <= na;
      52          datum = read2(read_file);
      53          stack_arg(read_indx, na) = datum;
      54
      55          read_indx = read_indx + 1;
      56      end while;
      57
      58      read1 = spec_om;
      59
      60
      61      end fnct read1;
       1 .=member read2
       2      fnct read2(id);
       3
       4$ this routine reads the next item from file 'id' and converts it
       5$ into its internal value.
       6
       7$ the actual -read2- routine handles the recursive cases; primitive
       8$ cases are handled off line. on each recursive level we keep a
       9$ count of the number of items read. when we begin reading a
      10$ composite object, we push both the count, and a code of 0 for
      11$ sets and 1 for tuples. both the count and the code are setl
      12$ integers.
      13
      14$ when we enter read2 there are two possibilities:
      15
      16$ 1. we are in the middle of a read which was interrupted by a garbage
      17$    collection. we jump to the appropriate label and continue the
      18$    read.
      19
      20$ 2. we are starting a new read. at this point rd_char is undefined,
      21$    and we must do getc to get the first character.
      22
      23$ after we are finished with each character we do a getc. when we
      24$ finish reading each item rd_char contains the first character of
      25$ the next item.
      26
      27$ when we finish reading the top level object we must back up one
      28$ character so that it can be read again the next time we use this
      29$ file.
      30
      31
      32      size id(ps);            $ little file identifier
      33
      34      size read2(hs);         $ specifier returned
      35
      36      size readnum(hs),       $ lower level read functions
      37           readstr(hs),
      38           rdbool(hs),
      39           rdname(hs),
      40          setform(hs),        $ set-former utility
      41          anyc(ps),           $ seek character in given class
      42           tupform(hs);
      43
      44      access nsread;          $ nameset with static variable
      45
      46
      47$ jump on read_case to the proper label, and either start or
      48$ continue read.
      49
      50      go to case(read_case) in read_init to read_error;
      51
      52
      53/case(read_init)/             $ initialze to start read
      54
      55      read_cntr = zero;
      56
      57      getc(id);
      58
      59
      60/entry/                       $ recursive entry point
      61
      62
      63      if  (anyc(rd_char,2)) rd_char = 1r ;
      64$ 2 above should be ss_separ, code maps separators to blanks.
      65      read_case = lexclass(rd_char);
      66      go to case(read_case) in read_num to read_error;
      67
      68
      69/case(read_num)/              $ read integer or real
      70
      71      heap(s_io1) = readnum(id);  $ read number
      72
      73      go to exit;
      74
      75
      76/case(read_str)/              $ read quoted string
      77
      78      heap(s_io1) = readstr(id);  $ read string
      79
      80      go to exit;
      81
      82
      83/case(read_set1)/             $ set former '@'
      84
      85      push2(read_cntr, zero);
      86      savet   = t;
      87      read_t2 = t;
      88
      89      read_cntr = zero;
      90
      91      getc(id);
      92      go to entry;
      93
      94
      95/case(read_set2)/             $ set former '<'
      96
      97      getc(id);
      98
      99      if rd_char ^= 1r< then backc(id); end if;
     100
     101      go to case(read_set1);
     102
     103
     104
     105/case(read_tup1)/             $ start reading tuple
     106
     107      push2(read_cntr, one);
     108      savet   = t;
     109      read_t2 = t;
     110
     111      read_cntr = zero;
     112
     113      getc(id);
     114      go to entry;
     115
     116
     117/case(read_tup2)/             $ tuple former '(' or '(/'
     118
     119      getc(id);
     120
     121      if rd_char ^= 1r/ then
     122          backc(id);
     123      end if;
     124
     125      go to case(read_tup1);
     126
     127
     128
     129/case(read_set3)/             $ end of set '\'
     130
     131$ see if the opening token was '@'.
     132      if (heap(t + ivalue_ read_cntr) ^= zero) go to fail;
     133
     134      heap(s_io1) = setform(f_uset, ivalue_ read_cntr);
     135
     136      pop2(read_key, read_cntr);
     137      savet   = t;
     138      read_t2 = t;
     139
     140      getc(id);               $ get character after '\'
     141
     142      go to exit;
     143
     144
     145/case(read_set4)/             $ end of set - '>>'
     146
     147      getc(id);
     148
     149      if rd_char ^= 1r> then backc(id); end if;
     150
     151      go to case(read_set3);
     152
     153
     154/case(read_tup3)/             $ end of tuple ']' or ')'
     155
     156$ see if opening token was '['
     157      if (heap(t + ivalue_ read_cntr) ^= one) go to fail;
     158
     159      heap(s_io1) = tupform(f_tuple, ivalue_ read_cntr);
     160
     161      pop2(read_key, read_cntr);
     162      savet   = t;
     163      read_t2 = t;
     164
     165      getc(id);               $ get character after ']'
     166
     167      go to exit;
     168
     169
     170/case(read_tup4)/             $ end of tuple '/'
     171
     172      getc(id);
     173      if (rd_char ^= 1r)) go to case(read_error);
     174
     175      go to case(read_tup3);
     176
     177
     178
     179/case(read_blank)/            $ blanks between items
     180
     181      until anyc(rd_char, 2) = no;
     182          getc(id);
     183      end until;
     184
     185$ if the blanks are followed by a comma then skip past it.
     186      if rd_char = 1r, then
     187          getc(id);
     188      end if;
     189
     190      go to entry;
     191
     192/case(read_bool)/             $ boolean
     193
     194      heap(s_io1) = rdbool(id);
     195      go to exit;
     196
     197
     198/case(read_name)/             $ name (to be converted to string)
     199
     200      heap(s_io1) = rdname(id);
     201      go to exit;
     202
     203
     204/case(read_om)/               $ read omega
     205
     206
     207      heap(s_io1) = spec_om;
     208
     209      getc(id);               $ get next character
     210
     211      go to exit;
     212
     213
     214/case(read_eof)/              $ trying to read past eof
     215
     216$ if we are at the outermost level, return omega. otherwise we
     217$ abort.
     218
     219      if t = read_t1 then
     220          heap(s_io1) = spec_om;
     221          go to exit;
     222
     223      else
     224          call err_fatal(15);
     225
     226      end if;
     227
     228
     229/case(read_error)/            $ illegal starting character
     230
     231$ this error occurs when the next character cannot begin a legal
     232$ input item.
     233
     234      call err_fatal(16);
     235
     236
     237/fail/                        $ mismatching brackets
     238
     239      call err_fatal(17);
     240
     241
     242
     243
     244/exit/                        $ recursive exit point
     245
     246      read_case = read_term;
     247
     248      if rd_char = 1r, then   $ advance
     249          getc(id);
     250      end if;
     251
     252/case(read_term)/
     253
     254      if t ^= read_t1 then    $ read next set/tuple element
     255          push1(heap(s_io1));
     256          savet   = t;
     257          read_t2 = t;
     258
     259          add1(read_cntr);
     260          go to entry;        $ read next item
     261      end if;
     262
     263      $ n.b. t = read_t1
     264
     265      read_case = read_init;  $ so we start fresh next time
     266      backc(id);              $ return next character
     267
     268      read2 = heap(s_io1);    $ get result
     269      heap(s_io1) = 0;
     270
     271
     272      end fnct read2;
       1 .=member readnum
       2      fnct readnum(id);
       3
       4$ this routine reads an integer or real and returns a specifier
       5$ for it. we assume that the value is small enough to fit in 1 word.
       6
       7
       8      size id(ps);            $ little file identifier
       9
      10      size readnum(hs);       $ specifier returned
      11
      12      size p(ps),             $ pointer to real
smfe   3           val1(ps);          $ integer for character
      14
smfe   4      real val;               $ real to return
      16
      17      size read_neg(1);       $ flags negative value
      18
      19      size expval(ws);        $ exponent value in powers of 10
      20
      21      size numstrng (cs);     $ number read as an array of characters
      22      dims numstrng (253);    $ maximum of 250 character long numbers
      23
      24      size word(hs);          $ word for building ints
      25      size len(ps);           $ length of array actually used
      26
      27      size readint(hs);       $ functions called
smfe   5 .+mc size ctpc(cs);          $ converts character to primary case
mjsa  36      size i(ps);             $ loop index
mjsa  37      size lint_flag(1);      $ flags when integer must be long
mjsa  38      size ss(ssz);           $ string specifier for numeric string
mjsa  39      size number_str(hs);    $ specifier for numeric string
mjsa  40      size valli(hs);         $ returns integer specifier
mjsa  41      size nulllc(ssz);       $ function to allocate string space
mjsa  42
mjsa  43
mjsa  44$ we begin by making sure that we have all the heap space we are likely
mjsa  45$ to read.  the largest quantity which might be read is a 251 digit long
mjsa  46$ integer.  since the magnitude of this value so outweighs the other
mjsa  47$ types of numbers which might be read in, it is sufficient to reserve
mjsa  48$ space only for this long integer.
mjsa  49
mjsa  50      reserve(hl_lint + li_dbas_digits(253));
mjsa  51
mjsa  52      word = 0;
mjsa  53      len = 0;
smfe   6      lint_flag = no;
mjsa  55
mjsa  56      if rd_char = 1r- then
mjsa  57         read_neg = yes;
mjsa  58         getc(id);
mjsa  60
mjsa  61      elseif rd_char = 1r+ then
mjsa  62         read_neg = no;
mjsa  63         getc(id);
mjsa  64
mjsa  65      else
mjsa  66         read_neg = no;       $ no sign therefore positive
mjsa  67      end if;
mjsa  68
mjsa  69
mjsa  70      while numeric(rd_char);
mjsa  71
smfe   7          if lint_flag = no then         $ only if we have not detected
mjsa  73              val1 = dig_val(rd_char);   $ a long integer should we do
mjsa  74              word = word * 10 + val1;   $ these
smfe   8              if (word > maxsi) lint_flag = yes;
mjsa  76          end if;
mjsa  77
smfe   9          if (word ^= 0) len = len + 1;
mjsa  79
mjsa  80          if len = 251 then
mjsa  81              call err_fatal(18);
mjsa  82          elseif len > 0 then
mjsa  83              numstrng(len) = rd_char;
mjsa  84          end if;
mjsa  85
mjsa  86          getc(id);
mjsa  87
mjsa  88      end while;
mjsa  89
mjsa  90 .-mc if (rd_char ^= 1r. & rd_char ^= 1re) then
mjsa  91 .+mc if (rd_char ^= 1r. & ctpc(rd_char) ^= 1re) then
mjsa  92
smfe  10          if lint_flag = no then
smfe  11              if (read_neg) word = - word;
mjsa  94              put_intval(word, readnum);
mjsa  95          else
mjsa  96              $ transform numstrng to a setl string
smfe  12              ss = nulllc(len + read_neg);
mjsa  98
mjsa  99              if (read_neg) icchar(ss, 1) = 1r-;
mjsa 100
mjsa 101              do i = 1 to len;
mjsa 102                  icchar(ss, i+read_neg) = numstrng(i);
mjsa 103              end do;
asca  22 .+ascebc     if (ascebc_flag) call ascstr(ss);  $ convert to ascii
mjsa 104
mjsa 105              ss_len(ss) = len + read_neg;
mjsa 106              build_spec(number_str, t_istring, ss);
mjsa 107
mjsa 108              $ call valli to actually create the long integer
mjsa 109              readnum = valli(number_str);
mjsa 110          end if;
mjsa 111
mjsa 112          return;             $ since this was an integer we return
mjsa 113
mjsa 114      end if;
      81$
      82$ absorb fraction and exponent into array
      83$
      84      if word = 0 then
      85          len = 1;
      86          numstrng(len) = 1r0;
      87      end if;
      88
      89      if (rd_char = 1r.) then
      90          len = len + 1;
      91          if len = 251 then
      92               call err_fatal(18);
      93          end if;
      94          numstrng(len) = rd_char;
      95          getc(id);
      96
      97          while numeric(rd_char);
      98
      99              len = len + 1;
     100              if len = 251 then
     101                   call err_misc(57);
     102              end if;
     103              numstrng(len) = rd_char;
     104
     105              getc(id);
     106
     107          end while;
     108
     109      end if;
     111$
     112$  we are now at an exponent or at the end of the real
     113$
     115 .-mc  if rd_char = 1re then
     116 .+mc  if ctpc(rd_char) = 1re then
     117                              $ absorb exponent into numstrng
     118          len = len+1;
     119          if len = 251 then
     120               call err_misc(57);
     121          end if;
     122          numstrng(len) = rd_char;
     123
     124          getc(id);
     125
     126          if rd_char = 1r+ .or. rd_char = 1r- then
     127
     128              len = len + 1;
     129              if len = 251 then
     130                   call err_misc(57);
     131              end if;
     132              numstrng(len) = rd_char;
     133
     134              getc(id);
     135
     136          end if;
     137
     138          while numeric(rd_char);
     139
     140              len=len+1;
     141              if len = 251 then
     142                   call err_misc(57);
     143              end if;
     144              numstrng(len)=rd_char;
     145
     146              getc(id);
     147
     148          end while;
     149
     150      end if;
     151
     152$  we have now absorbed a real into the character array numstrng
     153
     154$  the conversion is done by a pair of little library routines, actu
     155$  coded in assembly language.
     156
     157      call 7nvnum$io(numstrng, len, expval);  $  formats numstrng for
     158
     159      if numstrng(len+2) then         $ bad exponent
     160          call err_misc(57);
     161      end if;
     162
     163      if numstrng(len+3) > 1 then $ point present adjust exponent
     164          expval = expval - (numstrng(len+3)-1);
     165      end if;
     166
     167      call 7ncefr$io(val, numstrng, len, expval);  $ conversion
     168
     169      if numstrng(len+2) then         $ bad value message
     170          call err_misc(57);
     171      end if;
     172
     173      if (read_neg) val = - val;
     174
     175      get_real(p);
     176      rval(p) = val;
     177
     178      build_spec(readnum, t_real, p);
     179
     180
     181      end fnct readnum;
       1 .=member readstr
       2      fnct readstr(id);
       3
       4$ this routine reads a quoted string and returns a specifier for it.
       5$ the flag -read_flag- is on if we were interrupted by a garbage
       6$ collection during the last read. if so, we continue where we
       7$ left off.
       8
       9$ the code for building strings is very conservative about calling
      10$ primitives such as 'explc' to build and extend strings. this could
      11$ by done much more efficiently by duplicating some of the string
      12$ code in line. for the moment we play it safe, and avoid building
      13$ illformed heap blocks.
      14
stra 312$ for now, always return a long string.  it would be possible to return
stra 313$ a single character result if the result string has length 0 or 1.
      15
      16      size id(ps);            $ little file identifier
      17
      18      size readstr(hs);       $ specifier returned
      19
      20      size nulllc(ssz),       $ generates null string specifier
      21           convert(hs);       $ conversion routine
asca  23 .+ascebc size aschar(cs);    $ ebcdic-to-ascii conversion
      22
      23      access nsread;
      24
      25
      26      if (read_flag) go to loop;  $ continue where we left off.
      27
      28
      29/init/                        $ initialize for read
      30
      31      read_flag = yes;
      32
      33$ initialize read_len to 0 and heap(s_io2) to the null
      34$ string.
      35
      36      read_len = 0;
      37      build_spec(heap(s_io2), t_istring, nulllc(0));
      38
      39/loop/                        $ read characters
      40
      41      while 1;
      43          if mod(read_len, chpw) = 0 then $ current word is full
      44              read_ss = value(s_io2);
      45              call explc(read_ss, read_len+1);
      46              value(s_io2) = read_ss;
      47          end if;
      48
      49          getc(id);
      50
      51          if filestat(id, end) then
      52              call err_misc(45);
      53              quit;
      54          end if;
      55
      56          if rd_char = 1r' then
      57              getc(id);
      58              if (rd_char ^= 1r') quit;
      59          end if;
      60
      61          read_len = read_len + 1;
asca  24 .+ascebc.
asca  25          if (ascebc_flag) rd_char = aschar(rd_char);  $ change to ascii
asca  26 ..ascebc
      62          icchar(value(s_io2), read_len) = rd_char;
      63
      64 .+ssi    ss_len(value(s_io2)) = read_len;
      65 .-ssi    ss_len(heap(s_io2))  = read_len;
      66
      67      end while;
      68
      69
      70      readstr = heap(s_io2);
      71      read_flag = no;         $ indicate read done
      72
      73
      74      end fnct readstr;
       1 .=member rdbool
       2      fnct rdbool(id);
       3
       4$ this routine reads a boolean from file 'id'.
       5
       6
       7      size id(ps);            $ little file identifier
       8
       9      size rdbool(hs);        $ specifier returned
      10
      11 .+mc size ctpc(cs);          $ converts character to primary case
      12
      13      getc(id);
      14
      15 .+mc rd_char = ctpc(rd_char); $ fold to primary case
      16
      17      if rd_char = 1rt then
      18          rdbool = heap(s_true);
      19      elseif rd_char = 1rf then
      20          rdbool = heap(s_false);
      21      else
      22          call err_fatal(16);
      23          rdbool = err_val(f_gen);
      24      end if;
      25
      26      getc(id); $ get next char
      27
      28
      29      end fnct rdbool;
       1 .=member rdname
       2      fnct rdname(id);
       3
       4$ this routine reads a name and returns a specifier for it.
       5$ the name is returned in the form of a setl string.
       6
       7$ the flag -read_flag- is on if we were interrupted by a garbage
       8$ collection during the last read. if so, we continue where we
       9$ left off.
      10
      11$ the code for building strings is very conservative about calling
      12$ primitives such as 'explc' to build and extend strings. this could
      13$ by done much more efficiently by duplicating some of the string
      14$ code in line. for the moment we play it safe, and avoid building
      15$ illformed heap blocks.
      16
      17
      18      size id(ps);            $ little file identifier
      19
      20      size rdname(hs);        $ specifier returned
      21
      22      size nulllc(ssz);       $ generates null string specifier
      23      size anyc(ps);          $ searches for character in string set
      24      size convert(hs);       $ conversion routine
asca  27 .+ascebc size aschar(cs);    $ ebcdic-to-ascii conversion
      25
      26      access nsread;
      27
      28
      29      if ^ read_flag then
      30          read_flag = yes;    $ indicate start of read
      31
      32          $ initialize read_len and heap(s_io2)
      33          build_spec(rdname, t_istring, nulllc(1));
      34          heap(s_io2) = rdname;
      35
      36          read_ss = value_ rdname;   read_len = 1;
asca  28 .+ascebc if (ascebc_flag) rd_char = aschar(rd_char);  $ change to ascii
      37          icchar(read_ss, 1) = rd_char;   ss_len(read_ss) = 1;
      38      end if;
      39
      40      read_ss = value(s_io2);
      41
      42      while 1;
      43          if mod(read_len, chpw) = 0 then $ current word is full
      44              call explc(read_ss, read_len+1);
      45              value(s_io2) = read_ss;
      46          end if;
      47
      48          getc(id);
      49
      50          if (filestat(id, end))             quit while 1;
      51          if (anyc(rd_char, 4+8+16+32) = no) quit while 1;
      52          $ above matches letter, digit or underline
      53
asca  29 .+ascebc if (ascebc_flag) rd_char = aschar(rd_char);  $ change to ascii
      54          read_len = read_len + 1;   ss_len(read_ss) = read_len;
      55          icchar(read_ss, read_len) = rd_char;
      56      end while 1;
      57
      58      rdname = heap(s_io2);
      59      read_flag = no;         $ indicate read done
      60
      61
      62      end fnct rdname;
       1 .=member putr
       2      fnct putr(na);
       3
       4$ this is the setl 'put' function.
       5
       6      size na(ps);  $ number of arguments
       7
       8      size putr(hs);  $ value returned
       9
strb  82      size name(hs);          $ file name
strb  83      size id(ps);            $ little file id
strb  84      size rc(ws);            $ return code
strb  85      size arg(hs);           $ item to be output
strb  86      size ss(ssz);           $ string specifer
strb  87      size i(ps);             $ loop index
      18
strb  88      size file_id(ps);       $ looks up little file id
strb  89      size nulllc(ssz);       $ allocates null string
      20
      21
strb  90 .-env_pss.
strb  91      call err_fatal(49);
      24 .+env_pss.
      25
      26      name = stack_arg(1, na);
      27
strb  92      until 1;  $ exit when file id has been determined.
strb  93          until 2;  $ exit when not short null string.
strb  94              if (otype_ name ^= t_string) quit until 2;
strb  95              if (sc_nchars_ name ^= 0) quit until 2;
strb  96
strb  97              $ nullstring ---> standard output file
strb  98              id = out_file;
strb  99              quit until 1;
strb 100          end until 2;
strb 101          until 2;  $ exit when not long null string.
strb 102              if (otype_ name ^= t_istring) quit until 2;
strb 103              if (ss_len(value_ name) ^= 0) quit until 2;
strb 104
strb 105              $ nullstring ---> standard output file
strb 106              id = out_file;
strb 107              quit until 1;
strb 108          end until 2;
strb 109
strb 110          id = file_id(name, io_put);  $ look-up little file id
strb 111      end until 1;
      34
      37      if (filestat(id, column) ^= 1) put, skip; $ new line
      38
      39      do i = 2 to na;
      40          arg = stack_arg(i, na);
      41
strb 112          if otype_ arg = t_string then
strb 113              ss = nulllc(1); ss_len(ss) = sc_nchars_ arg;
strb 114              if (sc_nchars_ arg) icchar(ss, 1) = scchar(arg, 1);
strb 115          elseif otype_ arg = t_istring then
strb 116              ss = value_ arg;
strb 117          else
strb 118              call err_type(29);
strb 119              cont do;
strb 120          end if;
strb 121
strb 122 .+ascebc.
strb 123          $ if ascii mode, convert string to ebcdic before output.
strb 124          if (ascebc_flag) call ebcstr(ss);
strb 125 ..ascebc
strb 126          call envpss(id, rc, ss, heap);
strb 127 .+ascebc.
strb 128          $ if ascii mode, convert string to ebcdic before output.
strb 129          if (ascebc_flag) call ascstr(ss);
strb 130 ..ascebc
      47      end do;
      48
      49      putr = spec_om;
      50
      51 ..env_pss
      52
      53
      54      end fnct putr;
       1 .=member getr
       2      fnct getr(na);
       3
       4$ this is the setl 'get' routine.
       5
       6      size na(ps);            $ number of arguments
       7
       8      size getr(hs);          $ value returned
       9
      10      size name(hs);          $ file name
      11      size id(hs);            $ little file identifier
      12      size spec(hs);          $ datum to be read
      13      size len(ps);           $ linesize
      14      size ss(ssz);           $ string specifier
      15      size ptr(ps);           $ pointer to character block
      16      size rc(ps);            $ return code from little getvsio
      17      size i(ps);             $ loop index
      18
      19      size file_id(ps);       $ looks up file id
      20      size nulllc(ssz);       $ builds null string
      21
      22
strb 131 .-env_gss.
strb 132      call err_fatal(49);
      25 .+env_gss.
      26
      27      name = stack_arg(1, na);
      28
strb 133      until 1;  $ exit when file id has been determined.
strb 134          until 2;  $ exit when not short null string.
strb 135              if (otype_ name ^= t_string) quit until 2;
strb 136              if (sc_nchars_ name ^= 0) quit until 2;
strb 137
strb 138              $ nullstring ---> standard input file
strb 139              id = in_file;
strb 140              quit until 1;
strb 141          end until 2;
strb 142          until 2;  $ exit when not long null string.
strb 143              if (otype_ name ^= t_istring) quit until 2;
strb 144              if (ss_len(value_ name) ^= 0) quit until 2;
strb 145
strb 146              $ nullstring ---> standard input file
strb 147              id = in_file;
strb 148              quit until 1;
strb 149          end until 2;
strb 150
strb 151          id = file_id(name, io_get);  $ look-up little file id
strb 152      end until 1;
      35
      36      last_id = id;           $ update 'last input file accessed'
      37
      38      len  = filestat(id, linesize);
      39      $
      40      $ we begin by allocating a null string for each of the
      41      $ arguments.  this way we cannot run out of space after we
      42      $ have started the read.
      43      $
      44      do i = 2 to na;
      45          ss = nulllc(len);   ss_len(ss) = len;
      46
      47          build_spec(spec, t_oistring, ss);
      48          stack_arg(i, na) = spec;
      49      end do;
      50      $
      51      $ then we read the next (na-1) lines of file 'id'
      52      $
      53      do i = 2 to na;
      54          ss = value_ stack_arg(i, na);
      55
      56          call envgss(id, rc, ss, heap);   if (rc ^= 0) quit do;
asca  38 .+ascebc if (ascebc_flag) call ascstr(ss);  $ convert to ascii
      57
      58          value_ stack_arg(i, na) = ss;
      59          is_om_ stack_arg(i, na) = no;
      60      end do;
      61
      62      endline(id);            $ set cursor to end of line
      63
      64      getr = spec_om;
      65
      66 ..env_gss
      67
      68
      69      end fnct getr;
       1 .=member ascebc
       2 .+ascebc.
       3      subr ascstr(ss);  $ convert string to ascii
       4
       5      size ss(ssz);           $ string specifier
       6      size i(ps);             $ loop index
       7      size aschar(cs);        $ ebcdic-to-ascii conversion function
       8
       9      do i = 1 to ss_len(ss);
      10          icchar(ss,i) = aschar(icchar(ss,i));
      11      end do;
      12
      13      end subr ascstr;
      14 ..ascebc
       1 .=member ebcstr
       2 .+ascebc.
       3      subr ebcstr(ss);  $ convert string to ebcdic
       4
       5      size ss(ssz);           $ string specifier
       6      size i(ps);             $ loop index
       7      size ebchar(cs);        $ ascii-to-ebcdic conversion function
       8
       9      do i = 1 to ss_len(ss);
      10          icchar(ss,i) = ebchar(icchar(ss,i));
      11      end do;
      12
      13      end subr ebcstr;
      14 ..ascebc
       1 .=member putb
       2      fnct putb(na);
       3
       4$ this is the setl 'putb' function. it gets the identifier then
       5$ calls putb1 to write out each argument.
       6
       7      size na(ps);  $ number of arguments
       8
       9      size putb(hs);  $ value returned
      10
      11      size name(hs),  $ file name
      12           id(hs),   $ file id
      13           j(ps);     $ loop index
      14
      15      size putb1(hs),  $ lower level function
      16           file_id(ps);  $ looks up file id
      17
      18
      19      name = stack_arg(1, na);
      20      id   = file_id(name, io_write);
      21
      22$ before we start writing anything out we reserve all the space that
      23$ putb1 is likely to need and disbale the garbage collector.
      24
      25      reserve(reserve_io);
      26      can_collect = no;
      27
      28      do j = 2 to na;
      29          putb = putb1(id, stack_arg(j, na));
      30      end do;
      31
      32      can_collect = yes; $ renable garbage collector
      33
      34
      35      end fnct putb;
       1 .=member putb1
       2      fnct putb1(id, a);
       3
       4$ this is the main routine for binary output.  it writes an object
       5$ 'a' onto file 'id'.
       6
       7$ the external form begins with a binary header block which
       8$ has a type field and a value field.  the type field is one
       9$ of the binary types bt_xxx.
      10
      11$ the external form of a setl value is a function of its type:
      12
      13$ 1. short objects:
      14
      15$    short objects are represented according to their type.
      16$    in general, a one-word data block is written.
      17
      18$ 2. reals:
      19
      20$    reals are represented by header block followed by their
      21$    rval fields.
      22
      23$ 3. long ints, strings, and atoms:
      24
      25$    these are represented by:
      26
      27$    a. header block of appropriate type
      28$    b. a data block.
      29
      30$ 4. tuples:
      31
      32$    tuples are represented by:
      33
      34$    header block with type bt_tuple and bh_val set to zero.
      35$    there follows binary block for each element.
      36$    last entry followed by binary header block with value field of one.
      37
      38$ 5. sets and maps
      39
      40$    sets and maps have a representation similar to tuples
      41$    except that the type code is set or map respectively.
      42
      43$ objects of type element are always dereferenced before writing them
      44$ out.
      45
      46
      49      size id(ps),            $ file id
      50           a(hs);             $ value to write out
      51
      52      size putb1(hs);         $ value returned
      53
      54      size arg(hs);           $ copy of a
      55
      56      size tstart(ps);        $ initial recursion stack pointer
      57
      58      size val(hs),           $ untyped value
      59           spec(hs),          $ specifier
      60           p(ps),             $ misc. pointer
      61           len(ps),           $ block length
      62           i(ps),             $ loop index
      63           j(ps);             $ loop index
      64
      65      size pbits(ps),         $ ptbits of packed tuple
      66           pvect(ps),         $ ptvect of tuple
      67           bpos(ps);          $ bit position in tuple
      68
      69      size ss(ssz);           $ string specifier
      70
      71      size putbhdrblk(hs);    $ binary header block word
      72
      73      size tup(ps);           $ pointer to tuple
      74
      75      size t1(hs),            $ temporaries for values from 'nexts'
      76           t2(hs);
      77
mjsa 115      size putbli(hs);        $ function called for long integers
      78      size var_id(sds_sz);    $ function called
      79
      80$ stacked variables
      81
      82 .=zzyorg b $ reset counters for stack offsets
      83
      84      local(retpt);           $ return pointer
      85
      86      local(temp1);           $ pointer to tuple or specifier for set
      87      local(temp2);           $ index in tuple or element of set
      88      local(temp3);
      89
      90$ local macros
      91
      92      +* putbhdr(t, v)  =     $ put binary header block
      93          putbhdrblk = 0;
      94          bh_typ_ putbhdrblk = t;
      95          bh_val_ putbhdrblk = v;
      96          write id, putbhdrblk;
      97          **
      98
      99      +* putbdat1(v)  =       $ write one word data block
     100          write id, v;
     101          **
     102
     103      +* putbdatn(p, n)  =    $ write n word data block from heap
     104          write id, heap(p) to heap(p+(n)-1);
     105          **
     106
     107
     110      tstart = t;             $ save recursion stack pointer
     111
     112 .=zzyorg a                   $ reset counter for return labels
     113
     114      arg = a;                $ copy argument
     115
     116
     117/entry/                       $ recursive entry point
     118
     119      r_entry;                $ increment recursion stack
     120
     121
     122/switch/
     123
     124
     125      go to case(otype_ arg) in t_min to t_max; $ branch on type
     126
     127
     128/case(t_int)/                 $ short integers
     129
smfd  34      if ivalue_ arg < bh_val_max then
smfd  35          putbhdr(bt_sint, ivalue_ arg);
smfd  36      else
smfd  37          putbhdr(bt_int, 1);
smfd  38          putbdat1(ivalue_ arg);
smfd  39      end if;
smfd  40
     132      go to exit;
     133
     134/case(t_string)/              $ short character strings
     135
stra 314      len = sc_nchars_ arg;
stra 315
stra 316      if len = 0 then  $ write null string
stra 317          putbhdr(bt_string, len);
stra 318      else    $ write character, since sc_max = 1
stra 319          putbhdr(bt_char, scchar(arg, 1));
stra 320      end if;
stra 321
stra 322      go to exit;
stra 323
     137
     138/case(t_atom)/                $ short atom
     139
     140      if arg = heap(s_true) then
     141          putbhdr(bt_bool, 1);
     142          putbdat1(1);
     143
     144      elseif arg = heap(s_false) then
     145          putbhdr(bt_bool, 1);
     146          putbdat1(0);
     147
     148      else
     149          putbhdr(bt_atom, 1);
     150          putbdat1(value_ arg);
     151      end if;
     152
     153      go to exit;
     154
     155
     156/case(t_proc)/                $ procedures
     157
     158/case(t_lab)/                 $ labels
     159
     160      go to error;
     161
     162
     163/case(t_latom)/               $ long atom
     164
     165$ long atom block will be more than one word so that
     166$ can distinguish this case on subsequent read.
     167
     168      p   = value_ arg;
     169      len = la_nwords(p);
     170
     171      putbhdr(bt_atom, len);
     172      putbdatn(p, len);
     173
     174      go to exit;
     175
     176
     177/case(t_elmt)/                $ element
     178
     179      deref(arg);   go to switch;
     180
     181
     182/case(t_lint)/                $ long integer
     183
mjsa 116      putb1 = putbli(id, arg);
     190
     191      go to exit;
     192
     193
     194/case(t_istring)/             $ long character string
     195
     196      ss  = value_ arg;
     197      p   = ss_ptr(ss);
     198      len = ss_len(ss);
     199
     200      putbhdr(bt_string, len);
     201
     202$ write characters left-justified with zero fill
     203
     204      t1 = 0;                 $ used to build the word to be written
     205      p  = hs + 1;            $ character position
     206      do i = 1 to len;
     207          p = p - cs;         $ move to next character
     208          .f. p, cs, t1 = icchar(ss, i); $ insert character
     209
     210          if p = 1 then       $ if the word is filled, write it out
     211              putbdat1(t1);
     212
     213              p  = hs + 1;    $ reset the position
     214              t1 = 0;
     215          end if;
     216      end do;
     217
     218$ write the last word if it contains any characters
     219
     220      if p ^= hs + 1 then
     221          putbdat1(t1);
     222      end if;
     223
     224      go to exit;
     225
     226
     227/case(t_real)/                $ real
     228
     229$ n.b. this code assumes that 'rval' yields a word-size quantity
     230
     231      putbhdr(bt_real, 1);
     232      putbdat1(rval(value_ arg));
     233
     234      go to exit;
     235
     236
     237/case(t_tuple)/               $ tuples
     238
     239      temp1 = value_ arg;
     240      temp2 = 1;
     241
     242      putbhdr(bt_tuple, 0);
     243
     244      while temp2 <= nelt(temp1);
     245
     246          arg = tcomp(temp1, temp2);
     247          temp2 = temp2+1;
     248
     249          r_call;
     250      end while;
     251
     252      putbhdr(bt_tuple, 1);   $ mark end of tuple
     253
     254      go to exit;
     255
     256
     257/case(t_stuple)/              $ special tuple
     258
     259      go to error;
     260
     261
     262/case(t_set)/                 $ sets and maps
     263
     264/case(t_map)/
     265
     266$ all sets and maps are printed using the general next routine
     267
     268      temp3 = arg;
     269
     270      putbhdr(bt_set, 0);
     271
     272      call inext(t1, t2, temp3); $ initialize set iterator
     273      temp1 = t1;
     274      temp2 = t2;
     275
     276      while 1;
     277          t1 = temp1;
     278          t2 = temp2;
     279
     280          call nexts(t1, t2, temp3); $ advance iterator
     281          temp1 = t1;
     282          temp2 = t2;
     283
     284          if (is_om_ temp1) quit;
     285
     286          arg = temp1;
     287          r_call;
     288      end while;
     289
     290      putbhdr(bt_set, 1);     $ mark end of set
     291
     292      go to exit;
     293
     294
     295case_om                       $ omega types
     296
     297      if (otype_ arg = t_error) call err_fatal(45);
     298
     299      putbhdr(bt_omega, 0);
     300
     301      go to exit;
     302
     303
     304/error/                       $ error exit
     305
     306      call err_fatal(20);
     307
     308
     309/exit/                        $ recursive exit point
     310
     311      r_exit;
     312
     313      if t ^= tstart then     $ recursive return
     314          go to rlab(retpt) in 1 to zzya;
     315      end if;
     316
     317      putb1 = spec_om;
     318
     319      return;
     320
     321
     322$ drop local variables
     323
     324      macdrop2(retpt, temp1)
     325      macdrop2(temp2, temp3)
     326
     327$ drop local macros
     328
     329      macdrop (putbhdr)
     330      macdrop2(putbdat1, putbdatn)
     331
     332
     333      end fnct putb1;
       1 .=member getb
       2      fnct getb(na);
       3
       4$ this is the setl -getb- routine.  like -read1-, it can be inter-
       5$ rupted for garbage collections.  the variable -getb_indx- gives the
       6$ index of the current argument in the argument list.
       7
       8
       9      size na(ps);            $ number of arguments
      10
      11      size getb(hs);          $ value returned
      12
      13      size name(hs);          $ file name
      14
      15      size datum(hs);         $ datum returned by -getb1-
      16
      17      size nulltup(hs),       $ builds null tuple
      18           file_id(ps),       $ looks up file id
      19           getb1(hs);         $ lower level routine
      20
      21      access nsgetb;
      22
      23
      24$ begin execution
      25
      26      if getb_case = getb_init then $ initial entry
      27
      28$ make sure no other library routine is currently using the stack,
      29$ since the binary read routines are the only routines which format
      30$ it correctly.  this check is done by comparing the global stack
      31$ pointer -t- with the global stack pointer on entry of the library,
      32$ -savet-.
      33
      34          if (t ^= savet) call err_fatal(21);
      35
      36$ we keep two local stack pointers:
      37
      38$ getb_t1:    stack top at initial entry to binary read routines
      39
      40$ getb_t2:    reference point to update -getb_t1- after a garbage
      41$             collection moved the stack.
      42
      43          getb_t1 = t;
      44          getb_t2 = t;
      45
      46$ the first argument of the argument list is the setl file name.
      47$ first find the little file identifier corresponding to this name.
      48
      49          name      = stack_arg(1, na);
      50          getb_file = file_id(name, io_read);
      51
      52          getb_indx = 2;
      53
      54          last_id   = getb_file;  $ update 'last input file accessed'
      55
      56      else    $ continue read after garbage collection
      57          getb_t1 = getb_t1 + (savet - getb_t2); $ adjust stack pointer
      58          getb_t2 = savet;
      59
      60      end if;
      61
      62      while getb_indx <= na;
      63          datum = getb1(getb_file);
      64          stack_arg(getb_indx, na) = datum;
      65
      66          getb_indx = getb_indx + 1;
      67      end while;
      68
      69      getb = spec_om;
      70
      71
      72      end fnct getb;
       1 .=member getb1
       2      fnct getb1(id);
       3
       4$ this is the main binary read routine.  it reads a setl object
       5$ from file 'id' and returns its value.
       6
       7$ the external form of a setl object consists of a binary header
       8$ block followed by a type dependent data block.  this is
       9$ decsribed in greater detail in the binary write routine
      10$ putb1.
      11
      12$ getb is somewhat similar to the stream read routine except that
      13$ instead of jumping on the first character of each object we jump
      14$ on the type code of its specifier.
      15
      16$ we keep a count of the number of items read at each level of
      17$ recursion.  the counter is kept as a setl integer so that the
      18$ stack remains valid.
      19
      20$ there are three possibilities on entry to the routine:
      21
      22$ 1. we are about to start a new read:  read the outermost header
      23$    and jump on its type.
      24
      25$ 2. we have already read in the header for a long object,
      26$    and ran out of space before we could read in the data words:
      27$    jump on the type of the header.
      28
      29$ 3. we have just finished reading an object and ran out of space
      30$    as we were about to push it onto the stack.
      31
      32$ these cases are identifier by the macros 'getb_xxxx'; the current
      33$ case is given by the variable 'getb_case'.
      34
      35
      36      size id(ps);            $ little file identifier
      37
      38      size getb1(hs);         $ specifier returned
      39
      40      size j(ps),             $ loop index
      41           p(ps);             $ pointer into getb_word
      42
      43      size temp(ws);          $ used to read real
      44
      45      size setform(hs),       $ set former
      46           tupform(hs),       $ tuple former
      47           nulllc(ssz);       $ null string
mjsa 117      size getbli(hs);        $ function called for long integers
      48
      49      access nsgetb;          $ static variables
      50
      51
      52      go to c(getb_case) in getb_init to getb_term;
      53
      54
      55/c(getb_init)/                $ initialize and start new read
      56
      57/entry/
      58
      59      read id, getb_word;
      60
      61      if filestat(id, end) then
      62          getb1 = err_val(f_gen);
      63          return;
      64      end if;
      65
      66      getb_typ = bh_typ_ getb_word;
      67      getb_val = bh_val_ getb_word;
      68
      69      getb_case = getb_cont;
      70
      71
      72/c(getb_cont)/
      73
      74      if (getb_typ < bt_min ! bt_max < getb_typ) call err_fatal(62);
      75      go to case(getb_typ) in bt_min to bt_max;
      76
      77
smfd  41/case(bt_sint)/               $ unsigned integer
smfd  42
smfd  43      put_intval(getb_val, getb_spec);
smfd  44      heap(s_io1) = getb_spec;
smfd  45
smfd  46      go to exit;
smfd  47
smfd  48
      78/case(bt_int)/                $ integer
      79
mjsa 118      reserve(hl_lint + getb_val);
mjsa 119
mjsa 120      getb_spec   = getbli(id, getb_val);
mjsa 121      heap(s_io1) = getb_spec;
      87
      88      go to exit;
      89
      90
      91/case(bt_real)/               $ real
      92
      93      get_real(getb_ptr);
      94      read id, temp;   rval(getb_ptr) = temp;
      95
      96      build_spec(getb_spec, t_real, getb_ptr);
      97
      98      heap(s_io1) = getb_spec;
      99
     100      go to exit;
stra 324
stra 325
stra 326/case(bt_char)/               $ character
stra 327
stra 328      getb_spec = spec_char;  $ one-character template
stra 329      scchar(getb_spec, 1) = getb_val;
stra 330      heap(s_io1) = getb_spec;
stra 331
stra 332      go to exit;
     101
     102
     103/case(bt_string)/             $ character string
stra 333
stra 334      if getb_val <= sc_max then  $ can store as short string
stra 335          if getb_val = 0 then  $ null string
stra 336              build_spec(getb_spec, t_string, 0);
stra 337          else
stra 338              read id, getb_word;  $ get data word
stra 339              getb_spec = spec_char;  $ one-character template
stra 340              scchar(getb_spec, 1) = .f. hs+1-cs, cs, getb_word;
stra 341          end if;
stra 342
stra 343          heap(s_io1) = getb_spec;
stra 344
stra 345          go to exit;
stra 346      end if;
     104
     105      getb_ss = nulllc(getb_val); $ null string of proper length
     106      ss_len(getb_ss) = getb_val; $ set length
     107      build_spec(getb_spec, t_istring, getb_ss);
     108
     109      p = 1;
     110
     111      do j = 1 to getb_val;
     112          if p = 1 then       $ the current word is exhausted
     113              read id, getb_word;
     114              p = hs + 1;
     115          end if;
     116
     117          p = p - cs;         $ advance to the next character
     118          icchar(getb_ss, j) = .f. p, cs, getb_word;
     119      end do;
     120
     121      heap(s_io1) = getb_spec;
     122
     123      go to exit;
     124
     125
     126/case(bt_bool)/               $ boolean
     127
     128      read id, getb_word;
     129
     130      if getb_word then
     131          heap(s_io1) = heap(s_true);
     132      else
     133          heap(s_io1) = heap(s_false);
     134      end if;
     135
     136      go to exit;
     137
     138
     139/case(bt_atom)/               $ atom
     140
     141      if getb_val = 1 then    $ short atom
     142          read id, getb_word;
     143          build_spec(getb_spec, t_atom, getb_word);
     144
     145      else                    $ long atom
     146          get_heap(getb_val, getb_ptr);
     147          read id, heap(getb_ptr) to heap(getb_ptr+getb_val-1);
     148          build_spec(getb_spec, t_latom, getb_ptr);
     149      end if;
     150
     151      heap(s_io1) = getb_spec;
     152
     153      go to exit;
     154
     155
     156/case(bt_tuple)/              $ standard tuple
     157
     158      if getb_val = 1 then    $ marks end of tuple
     159
     160          heap(s_io1) = tupform(f_tuple, ivalue_ getb_cntr);
     161
     162          pop1(getb_cntr);
     163          savet   = t;
     164          getb_t2 = t;
     165
     166          go to exit;
     167
     168      else
     169          push1(getb_cntr);
     170          savet   = t;
     171          getb_t2 = t;
     172
     173          getb_cntr = zero;
     174          go to entry;
     175      end if;
     176
     177
     178/case(bt_set)/                $ sets
     179
     180      if getb_val = 1 then    $ marks end of set
     181
     182          heap(s_io1) = setform(f_uset, ivalue_ getb_cntr);
     183
     184          pop1(getb_cntr);
     185          savet   = t;
     186          getb_t2 = t;
     187
     188          go to exit;
     189
     190      else
     191          push1(getb_cntr);
     192          savet   = t;
     193          getb_t2 = t;
     194
     195          getb_cntr = zero;
     196          go to entry;
     197      end if;
     198
     199
     200/case(bt_map)/                $ maps
     201
     202      if getb_val = 1 then    $ marks end of set
     203
     204          heap(s_io1) = setform(f_umap, ivalue_ getb_cntr);
     205
     206          pop1(getb_cntr);
     207          savet   = t;
     208          getb_t2 = t;
     209
     210          go to exit;
     211
     212      else
     213          push1(getb_cntr);
     214          savet   = t;
     215          getb_t2 = t;
     216
     217          getb_cntr = zero;
     218          go to entry;
     219      end if;
     220
     221
     222/case(bt_omega)/              $ omega case
     223
     224      heap(s_io1) = spec_om;
     225      go to exit;
     226
     227
     228/error/                       $ error exit
     229
     230      call err_fatal(22);
     231
     232
     233/exit/                        $ recursive exit point
     234
     235      getb_case = getb_term;
     236
     237
     238/c(getb_term)/
     239
     240      if t = getb_t1 then     $ convert result and return
     241
     242          getb1 = heap(s_io1);
     243          heap(s_io1) = 0;
     244
     245          getb_case = getb_init;
     246
     247      else                    $ read the next tuple/set/map element
     248          push1(heap(s_io1));
     249          savet   = t;
     250          getb_t2 = t;
     251
     252          add1(getb_cntr);
     253          go to entry;
     254      end if;
     255
     256
     257      end fnct getb1;
       1 .=member putk
       2      fnct putk(na);
       3
       4$ this is the setl -putk- routine.
       5
       6      size na(ps);            $ number of arguments
       7
       8      size putk(hs);          $ value returned
       9
      10      call err_fatal(24);
      11
      12      end fnct putk;
       1 .=member getk
       2      fnct getk(na);
       3
       4$ this is the setl -getk- routine.
       5
       6      size na(ps);            $ number of arguments
       7
       8      size getk(hs);          $ value returned
       9
      10      call err_fatal(27);
      11
      12      end fnct getk;
       1 .=member getf
       2      fnct getf(na);
       3$
       4$ this is the setl -getf- routine.  like -read1-, it can be inter-
       5$ rupted for garbage collections.  the variable -intf_indx- gives the
       6$ index of the current argument in getf's argument list, and the
       7$ the variable -intf_argp- gives the index of the current argument
       8$ in the interface parameter list.
       9$
      10      size na(ps);            $ number of arguments
      11
      12      size getf(hs);          $ specifier returned
      13
      14      size datum(hs);         $ datum returned by getf1
      15
      16      size getf1(hs);         $ lower level routine
      17
      18      access nsintf;          $ global nameset with static variables
      19
      20
      21 .-defenv_envfor.
      22
      23      call err_fatal(49);
      24
      25 .+defenv_envfor.
      26
      27      if intf_case = intf_init then $ initial entry
      28
      29          intf_spec = stack_arg(1, na);
      30          if (otype_ intf_spec ^= t_int) call err_fatal(57);
      31          intf_argp = ivalue_ intf_spec;
      32
      33          if (intf_argp-1) + (na-1) > nelt(value(s_intf)) then
      34              call err_fatal(58);
      35          end if;
      36
      37          intf_indx = 2;
      38          intf_case = intf_cont;
      39      end if;
      40
      41      while intf_indx <= na;
      42          datum = getf1(tcomp(value(s_intf), intf_argp));
      43          stack_arg(intf_indx, na) = datum;
      44
      45          intf_indx = intf_indx + 1;
      46          intf_argp = intf_argp + 1;
      47      end while;
      48
      49      intf_case = intf_init;
      50
      51      getf = spec_om;
      52
      53 ..defenv_envfor
      54
      55
      56      end fnct getf;
       1 .=member getf1
       2
       3
       4 .+defenv_envfor.
       5
       6
       7      fnct getf1(arg);
       8$
       9$ this function controls the copy semantics between the interface and
      10$ the setl system per se.
      11$
      12      size arg(ws);           $ specifier for argument
      13
      14      size getf1(hs);         $ specifier returned
      15
      16      size p(ps);             $ pointer to heap block
stra 347      size ss(ssz);           $ string specifier
stra 348      size len(ps);           $ length of string
      17
      18      size convert(hs);       $ general conversion utility
      19      size copy1(hs);         $ general copy utility
      20
      21      access nsintf;          $ global nameset with static variables
      22
      23
      24      go to case(otype_ arg) in t_min to t_max;
      25
      26
      27/case(t_int)/                 $ short integer
      28
      29      getf1 = arg;
      30      return;
      31
      32
      33/case(t_string)/              $ short character string
      34
      35/case(t_atom)/                $ short atom
      36
      37/case(t_proc)/                $ procedure
      38
      39/case(t_lab)/                 $ label
      40
      41/case(t_latom)/               $ long atom
      42
      43/case(t_elmt)/                $ element-of-base
      44
      45      go to error;
      46
      47
      50/case(t_istring)/             $ long character string
stra 349
stra 350      ss = value_ arg;  $ get string specifier
stra 351      len = ss_len(ss);  $ get length of string
stra 352
stra 353      if len <= sc_max then  $ result is short character string
stra 354          if len = 0 then  $ result is null string
stra 355              build_spec(getf1, t_string, 0);
stra 356          else
stra 357              getf1 = spec_char;  $ one-character template
stra 358              scchar(getf1, 1) = icchar(ss, 1);
stra 359          end if;
stra 360
stra 361          return;  $ done
stra 362      end if;
stra 363
stra 364      $ fall through to t_lint case.
stra 365
      51
stra 366/case(t_lint)/                $ long integer
stra 367
      52/case(t_real)/                $ real
      53
      54      getf1 = copy1(arg);
      55      return;
      56
      57
      58/case(t_tuple)/               $ standard tuple
      59
      60      go to error;
      61
      62
      63/case(t_stuple)/              $ packed or untyped tuple
      64
      65      p = value_ arg;         $ get pointer to heap block
      66
      67      go to tc(htype(p)) in h_ptuple to h_rtuple;
      68
      69
      70/tc(h_ptuple)/                $ packed tuple
      71
      72      go to error;
      73
      74
      75/tc(h_ituple)/                $ tuple(untyped integer)
      76
      77/tc(h_rtuple)/                $ tuple(untyped real)
      78
      79      getf1 = convert(arg, f_tuple);
      80      return;
      81
      82
      83/case(t_set)/                 $ set
      84
      85/case(t_map)/                 $ map
      86
      87      go to error;
      88
      89
      90case_om                       $ omega types
      91
      92      go to error;
      93
      94
      95/error/                       $ error exit
      96
      97      call err_fatal(59);
      98
      99
     100      end fnct getf1;
     101
     102
     103 ..defenv_envfor
     104
     105
       1 .=member callf
       2      fnct callf(na);
       3$
       4$ this is the top-level routine for linking to an external routine,
       5$ assuming fortran calling conventions.
       6$
       7      size na(ps);            $ number of arguments
       8
       9      size callf(hs);         $ specifier returned
      10
      11      size ext_addr(ws);      $ address of external routine
      12      size ext_indx(hs);      $ index of external routine
      13      size arg_addr(ws);      $ address of parameter list
      14
      15      size spec(hs);          $ setl specifier
      16
      17      size callf2(hs);        $ lower level routine called
      18      size pimadr(ws);        $ returns absolute memory address
      19      size pigetw(ws);        $ returns memory contents
      20
      21      access nsintf;          $ global nameset with  static variables
      22
      23
      24 .-defenv_envfor.
      25
      26      call err_fatal(49);
      27
      28 .+defenv_envfor.
      29
      30      $ get the entry address of the external routine
      31      if (intf_extlen = 0 ! intf_extadr = 0) call err_fatal(60);
      32      spec = stack_arg(1, na);
      33      if (otype_ spec ^= t_int) call err_fatal(61);
      34      ext_indx = ivalue_ spec;
      35      if (ext_indx > intf_extlen) call err_fatal(61);
      36      ext_addr = pigetw(intf_extadr+(ext_indx-1)*mem_bpw);
      37
      38      $ get the low index for the parameter list
      39      spec = stack_arg(2, na);
      40      if (otype_ spec ^= t_int) call err_fatal(57);
      41      intf_argp = ivalue_ spec;
      42
      43      $ get the length of the parameter list
      44      spec = stack_arg(3, na);
      45      if (otype_ spec ^= t_int) call err_fatal(58);
      46      intf_na = ivalue_ spec;
      47
      48      if intf_argp - 1 + intf_na > nelt(value(s_intf)) then
      49          call err_fatal(58);
      50      end if;
      51
      52      $ allocate a block of untyped data on the stack.  this block
      53      $ consists of two parts:  the first part contains immediate
      54      $ data, such as the value of a short integer.  the second part
      55      $ forms the parameter list proper.  this list consists of an
      56      $ untyped integer n giving the length of the parameter list,
      57      $ followed by n setl words with the addresses of the actual
      58      $ parameters.
      59
      60      $ the constant 3 is derived as follows:  length of entry in
      61      $ parameter list is one setl word for the address, longest
      62      $ auxuliary storage needed is two setl words for the vax vms
      63      $ string descriptors.
      64      $ n+1 entries are allocated, accounting for the parameter list
      65      $ length and two skip words.
      66      reserve((intf_na+1)*3); $ no garbage collection hereafter
      67
      68      get_stack(2*intf_na);   $ get auxiliary storage
      69      intf_t2 = t;            $ keep pointer to start
      70      build_spec(intf_spec, t_skip, 2*intf_na+1);
      71      push1(intf_spec);
      72
      73      $ build the parameter list
      74      intf_indx = intf_na;
      75      intf_argp = intf_argp - 1 + intf_na;
      76
      77      while intf_indx > 0;
      78          call callf1(intf_indx, tcomp(value(s_intf), intf_argp));
      79
      80          intf_indx = intf_indx - 1;
      81          intf_argp = intf_argp - 1;
      82      end while;
      83
      84      push1(intf_na);         $ push length of parameter list
      85      intf_parm = t;          $ actual start of parameter list
      86      build_spec(intf_spec, t_skip, intf_na+2);
      87      push1(intf_spec);       $ mark block
      88
      89      arg_addr = pimadr(heap) + (intf_parm-1)*mem_bpw;
      90
      91      $ call external routine
      92      call picall(ext_addr, arg_addr);
      93
      94      $ pop the skip word and the number of arguments
      95      free_stack(2);
      96
      97      $ pop the parameter list, copying back values
      98      while intf_indx < intf_na;
      99          intf_indx = intf_indx + 1;
     100          intf_argp = intf_argp + 1;
     101
     102          tcomp(value(s_intf), intf_argp) =
     103                  callf2(intf_indx, tcomp(value(s_intf), intf_argp));
     104      end while;
     105
     106      $ free the auxiliary storage allocated above
     107      free_stack(2*intf_na+1);
     108      assert t = savet;       $ lest i forgot something
     109
     110      callf = spec_om;        $ return omega
     111
     112 ..defenv_envfor
     113
     114
     115      end fnct callf;
       1 .=member callf1
       2
       3
       4 .+defenv_envfor.
       5
       6
       7      subr callf1(indx, arg);
       8$
       9$ this routine pushes the address of its argument arg onto the setl
      10$ stack, thus forming the parameter list for the fortran call.  the
      11$ argument indx gives the index in the fortran parameter list, and is
      12$ used to address, together with the global intf_t2, the scratch
      13$ storage on the setl stack.
      14$
      15      size indx(ps);          $ formal parameter index
      16      size arg(hs);           $ specifier for actual parameter
      17
      18      size p(ps);             $ pointer to long object
      19
      20      size pimadr(ws);        $ return memory address
      21
      22      access nsintf;          $ global nameset with static variables
      23
      24
      25      go to case(otype_ arg) in t_min to t_max;
      26
      27
      28/case(t_int)/                 $ short integer
      29
      30      heap(intf_t2 + 2*(indx-1)) = ivalue_ arg;
      31      push1( pimadr(heap) + ((intf_t2-1) + 2*(indx-1)) * mem_bpw );
      32      return;
      33
      34
      35/case(t_string)/              $ short character string
      36
      37/case(t_atom)/                $ short atom
      38
      39/case(t_proc)/                $ procedure
      40
      41/case(t_lab)/                 $ label
      42
      43/case(t_latom)/               $ long atom
      44
      45/case(t_elmt)/                $ element-of-base
      46
      47      go to error;
      48
      49
      50/case(t_lint)/                $ long integer
      51
smfc  74      heap(intf_t2 + 2*(indx-1)) = getintli(arg);
      55      push1( pimadr(heap) + ((intf_t2-1) + 2*(indx-1)) * mem_bpw );
      56      return;
      57
      58
      59/case(t_istring)/             $ long character string
      60
suna  39 .+s32v.
      61      push1( pimadr(heap) + ((intf_t2-1) + 2*(indx-1)) * mem_bpw );
      62      call picrsd(heap(t), arg, heap);
suna  40 ..s32v
suna  41 .+s32u.
suna  42      get_stack(1);  $ reserve space for string address.
suna  43      call picrsd(t, arg, heap);  $ now store string address.
suna  44 ..s32u
suna  45 .+s37.
suna  46      push1( pimadr(heap) + ((intf_t2-1) + 2*(indx-1)) * mem_bpw );
suna  47      call picrsd(heap(t), arg, heap);
suna  48 ..s37
suna  49 .+s66.
suna  50      push1( pimadr(heap) + ((intf_t2-1) + 2*(indx-1)) * mem_bpw );
suna  51      call picrsd(heap(t), arg, heap);
suna  52 ..s66
suna  53 .+s68.
suna  54      get_stack(1);  $ reserve space for string address.
suna  55      call picrsd(t, arg, heap);  $ now store string address.
suna  56 ..s68
      63      return;
      64
      65
      66/case(t_real)/                $ real
      67
      68      heap(intf_t2 + 2*(indx-1)) = rval(value_ arg);
      69      push1( pimadr(heap) + ((intf_t2-1) + 2*(indx-1)) * mem_bpw );
      70      return;
      71
      72
      73/case(t_tuple)/               $ standard tuple
      74
      75      go to error;
      76
      77
      78/case(t_stuple)/              $ packed or untyped tuple
      79
      80      p = value_ arg;
      81
      82      go to tc(htype(p)) in h_ptuple to h_rtuple;
      83
      84
      85/tc(h_ptuple)/                $ packed tuple
      86
      87      go to error;
      88
      89
      90/tc(h_ituple)/                $ tuple(untyped integer)
      91
      92      push1( pimadr(heap) + ((p-1) + (hl_ituple+1)) * mem_bpw );
      93      return;
      94
      95
      96/tc(h_rtuple)/                $ tuple(untyped real)
      97
      98      push1( pimadr(heap) + ((p-1) + (hl_rtuple+1)) * mem_bpw );
      99      return;
     100
     101
     102/case(t_set)/                 $ set
     103
     104/case(t_map)/                 $ map
     105
     106      go to error;
     107
     108
     109case_om                       $ omega types
     110
     111      go to error;
     112
     113
     114/error/                       $ error exit
     115
     116      call err_fatal(59);
     117
     118
     119      end subr callf1;
     120
     121
     122 ..defenv_envfor
     123
     124
       1 .=member callf2
       2
       3
       4 .+defenv_envfor.
       5
       6
       7      fnct callf2(indx, arg);
       8$
       9$ this routine pops the current argument from the setl stack.  the
      10$ argument arg serves as a type indicator.  the argument indx is used,
      11$ together with the global intf_t2, to address the scratch section on
      12$ the setl stack.
      13$
      14      size indx(ps);          $ formal parameter index
      15      size arg(hs);           $ specifier for actual parameter
      16
      17      size callf2(hs);        $ specifier returned
      18
      19      size p(ps);             $ pointer to heap block
      20      size val(hs);           $ untyped value
      21
      22      access nsintf;          $ global nameset with static variables
      23
      24
      25      go to case(otype_ arg) in t_min to t_max;
      26
      27
      28/case(t_int)/                 $ short integer
      29
      30      val = heap(intf_t2 + 2*(indx-1));
      31      put_intval(val, intf_spec);
      32      go to esac;
      33
      34
      35/case(t_string)/              $ short character string
      36
      37/case(t_atom)/                $ short atom
      38
      39/case(t_proc)/                $ procedure
      40
      41/case(t_lab)/                 $ label
      42
      43/case(t_latom)/               $ long atom
      44
      45/case(t_elmt)/                $ element-of-base
      46
      47      go to error;
      48
      49
      50/case(t_lint)/                $ long integer
      51
      52      val = heap(intf_t2 + 2*(indx-1));
      53      put_intval(val, intf_spec);
      54      go to esac;
      55
      56
      57/case(t_istring)/             $ long character string
      58
      59      intf_spec = arg;
      60      go to esac;
      61
      62
      63/case(t_real)/                $ real
      64
      65      val = heap(intf_t2 + 2*(indx-1));
      66      put_realval(val, intf_spec);
      67      go to esac;
      68
      69
      70/case(t_tuple)/               $ standard tuple
      71
      72      go to error;
      73
      74
      75/case(t_stuple)/              $ packed or untyped tuple
      76
      77      p = value_ arg;
      78
      79      go to tc(htype(p)) in h_ptuple to h_rtuple;
      80
      81
      82/tc(h_ptuple)/                $ packed tuple
      83
      84      go to error;
      85
      86
      87/tc(h_ituple)/                $ tuple(untyped integer)
      88
      89/tc(h_rtuple)/                $ tuple(untyped real)
      90
      91      intf_spec = arg;
      92
      93      go to esac;
      94
      95
      96/case(t_set)/                 $ set
      97
      98/case(t_map)/                 $ map
      99
     100      go to error;
     101
     102
     103case_om                       $ omega types
     104
     105      go to error;
     106
     107
     108/esac/                        $ end case
     109
     110      free_stack(1);          $ pop stack
     111
     112      callf2 = intf_spec;
     113
     114      return;
     115
     116
     117/error/                       $ error exit
     118
     119      call err_fatal(59);
     120
     121
     122      end fnct callf2;
     123
     124
     125 ..defenv_envfor
     126
     127
       1 .=member putf
       2      fnct putf(na);
       3$
       4      size na(ps);            $ number of arguments
       5
       6      size putf(hs);          $ specifier returned
       7
       8      access nsintf;          $ global nameset with static variables
       9
      10
      11 .-defenv_envfor.
      12
      13      call err_fatal(49);
      14
      15 .+defenv_envfor.
      16
      17      if intf_case = intf_init then $ initial entry
      18
      19          $ initialise the pointer into the argument array
      20          intf_argp = stack_arg(1, na);
      21          if (otype_ intf_argp ^= t_int) call err_fatal(57);
      22          intf_argp = ivalue_ intf_argp;
      23
      24          if (intf_argp-1) + (na-1) > maxindx(value(s_intf)) then
      25              intf_spec = heap(s_intf);
      26              call exptup(intf_spec, ((intf_argp-1)+(na-1)));
      27              heap(s_intf) = intf_spec;
      28          end if;
      29
      30          intf_indx = 2;
      31          intf_case = intf_cont;
      32      end if;
      33
      34      while intf_indx <= na;
      35          call putf1(intf_argp, stack_arg(intf_indx, na));
      36
      37          intf_indx = intf_indx + 1;
      38          intf_argp = intf_argp + 1;
      39      end while;
      40
      41      intf_case = intf_init;
      42
      43      putf = spec_om;         $ return omega
      44
      45 ..defenv_envfor
      46
      47
      48      end fnct putf;
       1 .=member putf1
       2
       3
       4 .+defenv_envfor.
       5
       6
       7      subr putf1(argp, arg);
       8$
       9$ this routine transfers its argument arg to the fortran interface
      10$ communication tuple.  it controls the copy-semantics and the
      11$ representation restrictions for the interface.
      12$
      13      size argp(ws);          $ actual parameter list index
      14      size arg(hs);           $ value to be transmitted
      15
      16      size a(hs);             $ local copy of arg
      17
stra 368      size len(ps);           $ length of string
stra 369      size ss(ssz);           $ string specifier
      18      size p(ps);             $ pointer to long object
      19      size val(hs);           $ packed value
      20
      21      size convert(hs);       $ general conversion utility
      22      size copy1(hs);         $ general copy utility
stra 370      size nulllc(ssz);       $ allocates null string
      23
      24      access nsintf;          $ global nameset with static variables
      25
      26
      27      a = arg;                $ copy argument
      28
      29
      30/entry/
      31
      32      go to case(otype_ a) in t_min to t_max;
      33
      34
      35/case(t_int)/                 $ short integer
      36
      37      go to esac;
      38
      39
      40/case(t_string)/              $ short character string
stra 371
stra 372$ convert to long string.  this reduces the amount of interface code
stra 373$ that has to be written for strings.
stra 374
stra 375      len = sc_nchars_ a;  $ get length of string
stra 376      ss = nulllc(len);  $ allocate null string block
stra 377      ss_len(ss) = len;  $ set length of converted string
stra 378      if len then  icchar(ss, 1) = scchar(a, 1);  end if;
stra 379      build_spec(a, t_istring, ss);
stra 380
stra 381      go to esac;
stra 382
      41
      42/case(t_atom)/                $ short atom
      43
      44/case(t_proc)/                $ procedure
      45
      46/case(t_lab)/                 $ label
      47
      48/case(t_latom)/               $ long atom
      49
      50      go to error;
      51
      52
      53/case(t_elmt)/                $ element-of-base
      54
      55      deref(a);   go to entry;
      56
      57
      58/case(t_lint)/                $ long integer
      59
      62      maycopy(a);             $ copy if shared
      63
      64      go to esac;
      65
      66
      67/case(t_istring)/             $ long character string
      68
      69      a = copy1(a);           $ always copy strings
sunb  34 .+s68.
sunb  35      p = value_ a;  $ get string specifier of argument.
sunb  36      call explc(p, ss_len(p) + 1);
sunb  37      icchar(p, ss_len(p)+1) = 0;  $ string terminator for c.
sunb  38      build_spec(a, t_istring, p);
sunb  39 ..s68
      70
      71      go to esac;
      72
      73
      74/case(t_real)/                $ real
      75
      76      maycopy(a);             $ copy if shared
      77
      78      go to esac;
      79
      80
      81/case(t_tuple)/               $ standard tuple
      82
      83      intf_spec = tcomp(value_ a, 1);   deref(intf_spec);
      84
      85      if otype_ intf_spec = t_int ! otype_ intf_spec = t_lint then
      86          a = convert(a, f_ituple);
      87
      88      elseif otype_ intf_spec = t_real then
      89          a = convert(a, f_rtuple);
      90
      91      else
      92          go to error;
      93      end if;
      94
      95      go to esac;
      96
      97
      98/case(t_stuple)/              $ packed or untyped tuple
      99
     100      p = value_ a;
     101
     102      go to tc(htype(p)) in h_ptuple to h_rtuple;
     103
     104
     105/tc(h_ptuple)/                $ packed tuple
     106
     107      val = pcomp(p, 1);
     108      unpack(ptkey(p), val, intf_spec);
     109      deref(intf_spec);
     110
     111      if otype_ intf_spec = t_int ! otype_ intf_spec = t_lint then
     112          a = convert(a, f_ituple);
     113
     114      elseif otype_ intf_spec = t_real then
     115          a = convert(a, f_rtuple);
     116
     117      else
     118          go to error;
     119      end if;
     120
     121      go to esac;
     122
     123
     124/tc(h_ituple)/                $ tuple(untyped integer)
     125
     126/tc(h_rtuple)/                $ tuple(untyped real)
     127
     128      maycopy(a);             $ copy if shared
     129
     130      go to esac;
     131
     132
     133/case(t_set)/                 $ set
     134
     135/case(t_map)/                 $ map
     136
     137      go to error;
     138
     139
     140case_om                       $ omega types
     141
     142      go to error;
     143
     144
     145/esac/                        $ end case
     146
     147      tcomp(value(s_intf), argp) = a;
     148      if (nelt(value(s_intf)) < argp) nelt(value(s_intf)) = argp;
     149
     150      return;
     151
     152
     153/error/                       $ error exit
     154
     155      call err_fatal(59);
     156
     157
     158      end subr putf1;
     159
     160
     161 ..defenv_envfor
     162
     163
       1 .=member rewindr
       2      fnct rewindr(na);
       3
       4$ this is the setl rewind function
       5
       6      size na(ps);  $ number of arguments
       7
       8      size rewindr(hs);  $ returned value
       9
      10      size name(hs),  $ file name
      11           id(ps);  $ file id
      12
      13      size file_id(ps);  $ looks up file id
      14
      15      name = stack_arg(1, na);
      16      id   = file_id(name, io_rewind);
      17
      18      rewind id;
      19      endline(id);
      20
      21      rewindr = spec_om;
      22
      23      return;
      24
      25      end fnct rewindr;
       1 .=member eof
       2      fnct eof(na);
       3
       4$ this is the setl eof function. it returns true if the last file
       5$ accessed is at the end of file.
       6
       7      size na(ps);  $ number of arguments
       8
       9      size eof(hs);  $ specifier returned
      10
      11      if last_id = 0 then  $ no i-o yet
      12          eof = heap(s_false);
      13      elseif filestat(last_id, end) then
      14          eof = heap(s_true);
      15      else
      16          eof = heap(s_false);
      17      end if;
      18
      19
      20      end fnct eof;
       1 .=member eject
       2      fnct eject(na);
       3
       4$ this is the setl 'eject' function. it causes a page eject on
       5$ a specified file.
       6
       7      size na(ps);   $ number of arguments
       8
       9      size eject(hs);  $ returned value
      10
      11      size name(hs),  $ file name
      12           id(ps);    $ file id
      13
      14      size file_id(ps);  $ maps file name into id
      15
      16      if na = 0 then  $ use out_file as default
      17          id = out_file;
      18      else
      19          name = stack_arg(1, 1);
      20          id   = file_id(name, io_print);
      21      end if;
      22
      23      put id, page;
      24
      25      eject = spec_om;
      26
      27      return;
      28
      29      end fnct eject;
       1 .=member title
       2      fnct title(na);
       3
       4$ this is the setl 'title' function. it resets the main title
       5$ on the file 'output' and causes a page eject.
       6
       7      size na(ps);  $ number of arguments
       8
       9      size title(hs);  $ specifier returned
      10
      11      size str(sds_sz);   $ title as sds
      12
      13      size bldsds(sds_sz);  $ converts string to sds
      14
      15      if na = 0 then  $ turn off titling
      16          call stltitle(no, '');
      17      else            $ install new title
      18          str = bldsds(stack_arg(1, 1));
      19          call stltitle(yes, str);
      20      end if;
      21
      22      title = spec_om;
      23
      24      return;
      25
      26      end fnct title;
       1 .=member stltitle
       2      subr stltitle(titl, str);
       3
       4$ this routine sets up a new title on the system output file. its
       5$ arguments are:
       6
       7$ titl:   indicates enable/disable titling
       8$ str:    new title as an sds string
       9
      10      size titl(1),
      11           str(sds_sz);
      12
      13      size t_flag(1);  $ on if currently titling
      14      data t_flag = no;
      15
      16      size lines(ps);         $ lines per page
      17
      18
      19
      20      if titl then   $ enable titling
      21          if t_flag then  $ reset title
      22              call etitlr(0,     str,  2, 35);
      23              call contlpr(10, lines);   $ get lines per page
      24              call contlpr(15, lines);   $ set line number within page
      25
      26          else   $ start from scratch
      27              call contlpr( 6, yes);     $ set paging mode
      28              call contlpr( 7, yes);     $ set titling mode
      29              call contlpr( 8,  76);     $ set page number in col. 76
      30              call contlpr( 9,  41);     $ set date field in col. 41
      31              call contlpr(13,   0);     $ set number of current page
sunb  40              call contlpr(10, lines);   $ get lines per page
sunb  41              call contlpr(15, lines);   $ set line number within page
      32              call etitlr(0,     str,  2, 35);
      33              call etitlr(0,  'page', 71,  4);
      35
      36              t_flag = yes;
      37
      38          end if;
      39      else
      40          call contlpr(6, 0);   $ disable page numbering
      41          call contlpr(7, 0);   $ disable titleing
      42
      43          t_flag = no;
      44      end if;
      45
      47
      48      end subr stltitle;
       1 .=member fileid
       2      fnct file_id(name, use);
       3
       4$ this routine maps a setl string into a little file identifier
       5$ then checks that the 'access' attribute of the file is consistent
       6$ with an io code 'code'.
       7
       8$ we also set last_id to the number of the last input file
       9$ accessed.
      10
      11$ we merley perform a look up in an unbased map called 'fid'.
      12
      13      size name(hs),   $ file name
      14           use(ps);    $ use io_xxx
      15
      16      size file_id(ps);  $ integer returned
      17
      18      size p(ps),  $ pointer set by locate
      19           valid(1),  $ flags valid io operation
      20           acs(ps),           $ access mode of file
      21           im(hs),  $ map image
      22           temp1(hs), $ temps for calling 'from'
      23           temp2(hs);
asca  39      size file_title(sds_sz);  $ file title
      24
      25      size bldsds(sds_sz);  $ converts string to sds
      26
      27
      28      call locate(p, name, value(s_fid), no);
      29
      30      if (^ loc_found) go to nfound;
      31
      32      im = ebimag(p);
      33      file_id = value_ im;
      34
      35
      36      acs = filestat(file_id, access);
asca  40      file_title = bldsds(name); $ file title
      37
      38      go to case(use) in io_min to io_max;
      39
      40/case(io_get)/
      41
      42      if acs = io_put then  $ change access
asca  41          file file_id title = file_title,  access = get;
      44          endline(file_id);
      45
      46          valid = yes;
      47
      48      else
      49          valid = (acs = io_get);
      50      end if;
      51
      52      last_id = file_id;
      53
      54      go to esac;
      55
      56/case(io_print)/
      57
      58      if acs = io_get then  $ change access
asca  42          file file_id title = file_title, access = print;
      60          valid = yes;
      61
      62      else
      63          valid = (acs = io_put ! acs = io_print);
      64      end if;
      65
      66      go to esac;
      67
      68/case(io_put)/
      69
      70      if acs = io_get then  $ change access
asca  43          file file_id title = file_title, access = put;
      72          valid = yes;
      73
      74      else
      75          valid = (acs = io_put ! acs = io_print);
      76      end if;
      77
      78      go to esac;
      79
      80
      81/case(io_read)/
      82
      83      if acs = io_write then  $ change access
asca  44          file file_id title = file_title, access = read;
      85          valid = yes;
      86
      87      else
      88          valid = (acs = io_read);
      89      end if;
      90
      91      last_id = file_id;
      92
      93      go to esac;
      94
      95
      96/case(io_string)/
      97
      98      valid = no;
      99      go to esac;
     100
     101
     102/case(io_write)/
     103
     104      if acs = io_read then  $ change access
asca  45          file file_id title = file_title, access = write;
     106          valid = yes;
     107
     108      else
     109          valid = (acs = io_write);
     110      end if;
     111
     112      go to esac;
     113
     114
     115
     116/case(io_open)/
     117
     118      valid = no;  $ since file already open
     119      go to esac;
     120
     121
     122/case(io_rewind)/
     123
     124      valid = yes;
     125      go to esac;
     126
     127
     128/case(io_close)/
     129
     130$ remove the pair [name, file_id] from fid and add file_id to the
     131$ set of free file numbers.
     132
     133      call delete(value(s_fid), loc_prev, p, yes);
     134      call insert(p, im, value(s_free));
     135
     136      valid = yes;
     137      go to esac;
     138
     139/esac/
     140
     141      if (^ valid) call err_fatal(28);
     142
     143      return;
     144
     145
     146/nfound/     $ file not found
     147
     148$ if we are opening a new file we must obtain a file number for
     149$ it and add a pair to 'fid'.
     150
     151$ the variable 'fmax' contains the maximum file number so far,
     152$ and 'free' contains the set of all file numbers which have been
     153$ freed.
     154
     155      if use = io_open then
     156          temp2 = heap(s_free);
     157          call from(temp1, temp2);
     158
     159          heap(s_free) = temp2;
     160
     161          if is_om_ temp1 then
     162              add1(heap(s_fmax));
     163              temp1 = heap(s_fmax);
     164
     165              if (value_ temp1 > file_max) call err_fatal(29);
     166          end if;
     167
     168          call insert(p, name, value(s_fid));
     169          ebimag(p) = temp1;
     170
     171          file_id = value_ temp1;
     172
     173      else
     174          call err_fatal(30);
     175      end if;
     176
     177      end fnct file_id;
       1 .=member filemode
       2      fnct file_mode(name);
       3
       4$ this routine maps a setl string into a little flie access mode.
       5$ we simply do a map look up in the map 'fmode'.
       6
       7      size name(hs);  $ specifier for name
       8
       9      size file_mode(ps);  $ code io_xxx returned
      10
      11      size p(ps);   $ pointer returned by locate
      12
      13      call locate(p, name, value(s_fmode), no);
      14
      15      if (^ loc_found) call err_fatal(31);
      16
      17      file_mode = value_ ebimag(p);
      18      return;
      19
      20      end fnct file_mode;
       1 .=member newliner
       2      subr newliner(id);
       3
       4$ this routine reads a new line image into the buffer for file
       5$ 'id' and set its cursor to point to the first character
       6$ of the line.
       7
       8      size id(ps);    $ file id
       9
      10      size len(ps),   $ line length
      11           j(ps);  $ loop index
      12
      13      size bf(linesize_max*cs);  $ scratch buffer
      14
      15      len = filestat(id, linesize);
      16      if (len > linesize_max) len = linesize_max;
      17      get id, skip: bf, r(len);
      18
      19      .f. 1,    ws,              buffer(id) = blank_buffer;
      20      .f. ws+1, linesize_max*cs, buffer(id) = bf;
      21
      22      cursor(id) = ws + 1 + (len-1) * cs;
      23
      24$ if we are at the end of file we set each character of the
      25$ line to 'eof_char'.
      26
      27      if filestat(id, end) then
      28          do j = 0 to len-1;
      29              .f. 1 + ws + j*cs, cs, buffer(id) = eof_char;
      30          end do;
      31      end if;
      32
      33      rd_char = .f. cursor(id), cs, buffer(id);
      34
      35      end subr newliner;
       1 .=member bldsds
       2      fnct bldsds(spec);
       3
stra 383$ this routine converts a setl string to a little sds string.
       5
       6
       7      size spec(hs);   $ setl string
       8
       9      size bldsds(sds_sz);
      10
      11      size ss(ssz),  $ string specifier
      12           j(ps),    $ loop index
      13           org(ps),  $ sorg of string
      14           len(ps);  $ length of string
      15
      16
      22      bldsds = 0;
      23
stra 384      if otype_ spec = t_string then  $ short character string
stra 385          len = sc_nchars_ spec;  org = .sds. len + 1;
stra 386          slen bldsds = len;  sorg bldsds = org;
stra 387          if len then  .f. org-cs, cs, bldsds = scchar(spec, 1);  end;
stra 388
stra 389      else    $ long character string
stra 390          ss  = value_ spec;
stra 391          len = ss_len(ss);  org = .sds. len + 1;
stra 392          slen bldsds = len;  sorg bldsds = org;
stra 393          do j = 1 to len;
stra 394              .f. org - j*cs, cs, bldsds = icchar(ss, j);
stra 395          end do;
stra 396      end if;
asca  46
asca  47 .+ascebc if (ascebc_flag) call ebcsds(bldsds);  $ convert to ebcdic
      30
      31
      32      end fnct bldsds;
       1 .=member bldstr
       2      fnct bldstr(str);
       3
stra 397$ this routine builds a setl character string from a little sds string.
       5
       6      size str(sds_sz);
       7
       8      size bldstr(hs);  $ specifier returned
       9
      10      size ss(ssz),  $ string specifier
      11           j(ps),    $ loop index
      12           org(ps),  $ sorg of sds
      13           len(ps);  $ slen of sds
stra 398      size c(cs);             $ current character
      14
      15      size nulllc(ssz);  $ builds null string
stra 399 .+ascebc size aschar(cs);    $ ebcid-to-ascii conversion function
      16
      17      org = sorg str;
      18      len = slen str;
stra 400
stra 401      if len <= sc_max then  $ result is short string
stra 402          if len = 0 then  $ result is null string
stra 403              build_spec(bldstr, t_string, 0);
stra 404          else
stra 405              bldstr = spec_char;  $ one-character template
stra 406              c = .f. org - cs, cs, str;  $ get character
stra 407 .+ascebc     if (ascebc_flag) c = aschar(c);  $ convert to ascii
stra 408              scchar(bldstr, 1) = c;
stra 409          end if;
stra 410
stra 411          return;
stra 412      end if;
      19
      20      ss = nulllc(len);
      21
      22      ss_len(ss) = len;
      23
      24      do j = 1 to len;
      25          icchar(ss, j) = .f. org - j*cs, cs, str;
      26      end do;
asca  48 .+ascebc if (ascebc_flag) call ascstr(ss);  $ convert to ascii
      28      build_spec(bldstr, t_istring, ss);
      29
      30      return;
      31
      32      end fnct bldstr;
       1 .=member dumpio
       2      subr dumpio;
       3
       4$ this routine dumps the state of all files in case of an abort.
       5$ for now we merely print the current line of the input file.
       6
       7      size len(ps),  $ length of print file
       8           col(ps);  $ current column
       9
      10      size j(ps);  $ loop index
      11
      12      size line(cs); $ current line image
      13      dims line(130);
      14
      15      len = filestat(in_file, linesize);
      16      col = filestat(in_file, column);
      17
      18      get in_file, column(1): line(1) to line(len), r(1);
      19
      20      put, skip(2), column(7), 'current line of input file is: ',
      21           skip(1), column(2): line(1) to line(len), r(1),
      22           skip(1), column(7+col): 1r$, r(1);
      23
      24      return;
      25
      26      end subr dumpio;
       1 .=member copy1
       2      fnct copy1(arg);
       3
       4$ this routine performs a single level copy of a setl data object and
       5$ sets the share bits on the second level of the object. its argument
       6$ is a specifier, and a specifier is returned.
       7
       8$ if "arg" is omega then we call err_om and take one of
       9$ two actions depending on err_mode:
      10
      11$ 1. if we are doing full error detection we return the
      12$    appropriate error value.
      13
      14$ 2. otherwise we return a copy of the appropriate standard
      15$    omega. note that this must be a copy since we may use
      16$    it destructively.
      17
      18$ variable declarations
      19
      20      size copy1(hs);    $ specifier returned
      21
      22      size arg(hs);       $ specifier for object to be copied
      23
      24      size oldp(ps),     $ pointer to value to be copied
      25           newp(ps),    $ pointer to copy
      26           len(ps),      $ its length
      27           oldss(ssz),    $ old string specifier
      28           newss(ssz),     $ new string specifier
      29           j(ps);    $ loop index
      30
      31      size oldht(ps),    $ pointer to old hash table
      32           newht(ps),   $ pointer to new hash table
      33           nhedrs(ps),  $ number of hash headers
      34           p(ps),       $ misc. pointer
      35           ebsz(ps),    $ ebsize of set being copied
      36           total(ps),    $ total space needed
      37           map(1),   $ indicates we are copying a map
      38           old(ps),    $ pointer to eb being copied
      39           new(ps),    $ pointer to eb being copied to
      40           prev(ps),     $ pointer to last eb initialized
      41           head(ps);    $ pointer to current hash header of new set
      42
      43      size nulllc(ssz);  $ function called
      44
      45
      46$ begin execution
      47
      48 .+st init_time(st_copy);
      49
      50      if is_om_ arg then
      51          call err_om(13);
      52
      53          if err_mode = err_full then
      54              build_spec(copy1, t_error, codep);
      55              go to done;
      56          end if;
      57      end if;
      58
      59$ initialize the specifier for the result and jump on its type.
      60$ om - value can be used destructively.
      61
      62      copy1 = arg;    $ initialize type, etc.
      63      is_shared_ copy1 = no;
      64
      65      oldp = value_ arg;  $ get pointer to old block
      66
      67
      68$ branch on type of argument ignoring is-om flag.
      69
      70      go to case(type_ arg) in t_min to t_lmax;
      71
      72
      73
      74
      75/case(t_int)/      $ types which are never copied
      76
      77/case(t_string)/
      78
      79/case(t_atom)/
      80
      81/case(t_error)/
      82
      83/case(t_skip)/
      84
      85/case(t_proc)/
      86
      87/case(t_lab)/
      88
      89/case(t_latom)/
      90
      91/case(t_elmt)/
      92
      93      go to done;             $ nothing to do
      94
      95
      96/case(t_lint)/         $ long integers
      97
      98      len = li_nwords(oldp);   $ length of data area
      99      go to loop;
     100
     101/case(t_istring)/       $ long chars
     102
     103      oldss = value_ arg;     $ get original string specifier
     104      len = ss_len(oldss);
     105
     106      newss = nulllc(len);  $ get string block
     107      ss_len(newss) = len;
     108
     109      mvc(newss, oldss, len);   $ copy string
     110
     111      value_ copy1 = newss;     $ store new string specifier
     112
     113      go to done;
     114
     115
     116/case(t_real)/         $ reals
     117
     118      go to done;             $ no copy necessary
     119
     120
     121/case(t_tuple)/         $ tuples
     122
     123      len = tuplen(oldp);
     124
     125      get_heap(len, newp);  $ get new block
     126
     127      do j = 0 to hl_tuple-1; $ copy header
     128          heap(newp+j) = heap(oldp+j);
     129      end do;
     130
     131             $ copy elements, setting share bits.
     132      do j = 0 to maxindx(oldp);
     133          is_shared_ tcomp(oldp, j) = yes;
     134          tcomp(newp, j) = tcomp(oldp, j);
     135      end do;
     136
     137      value_ copy1 = newp;   $ save new value_
     138
     139      go to done;
     140
     141
     142/case(t_stuple)/            $ special tuples
     143
     144$ jump on header type to get size of tuple
     145      go to tc(htype(oldp)) in h_ptuple to h_rtuple;
     146
     147
     148/tc(h_ptuple)/       $ packed tuples
     149
     150      len = ptuplen(oldp);
     151      go to loop;
     152
     153/tc(h_ituple)/               $ integer tuples
     154
     155/tc(h_rtuple)/             $ real tuples
     156
     157      len = tuplen(oldp);
     158      go to loop;
     159
     160/case(t_set)/         $ sets and maps.
     161
     162/case(t_map)/
     163
     164$ jump on header type
     165      go to sc(htype(oldp)) in h_uset to h_lrmap;
     166
     167
     168/sc(h_uset)/          $ unbased sets and maps
     169
     170/sc(h_umap)/
     171$
     172$ to copy a set or map means to copy the set/map header,  its  hash
     173$ table header,  its template, its hash table,  and all its element
     174$ blocks.  we first allocate one large block which will suffice for
     175$ the whole of the new set,  and then subdivide this block into the
     176$ smaller blocks needed.
     177$
     178      oldht  = hashtb(oldp);            $ pointer to old hash table
     179      nhedrs = pow2(lognhedrs(oldht));  $ number of hash headers
     180      ebsz   = ebsize(oldht + hl_ht);   $ element block size
     181
     182      $ get space for the set header, the hash table header, the
     183      $ template block, the hash table, and the element blocks.
     184      $ assert hl_uset = hl_umap;
     185      total = hl_uset + hl_ht + nhedrs * hl_htb + (neb(oldht)+1) * ebsz;
     186      get_heap(total, newp);
     187
     188      $ initialize set/map header
     189      do j = 0 to hl_uset-1;
     190          heap(newp+j) = heap(oldp+j);
     191      end do;
     192
     193      $ initialize hash table header
     194      newht = newp + hl_uset; $ address of new hash table header
     195      hashtb(newp) = newht;   $ insert pointer into set header
     196
     197      do j = 0 to hl_ht-1;
     198          heap(newht+j) = heap(oldht+j);
     199      end do;
     200
     201$ copy the template block and hash table. we use a double loop over
     202$ the two sets. the outer loop iterates over hash headers and the
     203$ inner loop iterates over clash lists. the variables used in the
     204$ loop are:
     205
     206$ old:  current element of old set.
     207$ new:  current element of new set.
     208$ prev: previous element of new set.
     209$ head: used to remember current hash header of new set.
     210$ map:  flag set on for maps and off for sets.
     211$ p:    points to next unused heap word.
     212
     213      old  = oldht + hl_ht;   $ points to the old template block
     214      new  = newht + hl_ht;   $ points to the new template block
     215
     216      $ initialize the new template block
     217      do j = 0 to ebsz-1;
     218          heap(new+j) = heap(old+j);
     219      end do;
     220
     221      old  = eblink(old);     $ points to the first old hash header
     222      prev = new;             $ points to the new template
     223      head = new + ebsz;      $ points to the first new hash header
     224      map  = is_map(oldp);    $ flags u_map case
     225      p    = head + nhedrs * hl_htb;
     226                              $ points to the next new eb
     227
     228      while ^ is_ebtemp(old);
     229          if is_ebhedr(old) then
     230              new = head;   head = head + hl_htb;
     231
     232              htype(new)     = h_htb;
     233              hlink(new)     = 0;
     234              is_ebhedr(new) = yes;
     235              is_ebtemp(new) = no;
     236
     237          else
     238              new = p;   p = p + ebsz;
     239
     240              do j = 0 to hl_eb-1;           $ copy eb header
     241                  heap(new+j) = heap(old+j);
     242              end do;
     243
     244              is_shared_ ebspec(old) = yes;  $ copy specifier
     245              ebspec(new) = ebspec(old);
     246
     247              if map then                    $ copy image
     248                  is_shared_ ebimag(old) = yes;
     249                  ebimag(new) = ebimag(old);
     250              end if;
     251          end if;
     252
     253          eblink(prev) = new;   prev = new;   $ link and advance
     254          old = eblink(old);                  $ advance in original
     255      end while;
     256
     257      $ reset the last link to point to the template block
     258      eblink(prev) = template(newp);
     259
     260      value_ copy1 = newp;   $ save new value_
     261
     262      go to done;
     263
     264
     265/sc(h_lset)/          $ local subsets
     266
     267      call err_fatal(32);
     268
     269/sc(h_rset)/           $ remote subsets
     270
     271$ get length and jump to main loop
     272      len = rswords(oldp) + hl_rset;
     273      go to loop;
     274
     275/sc(h_lmap)/            $ local maps
     276
     277      call err_fatal(33);
     278
     279/sc(h_rmap)/         $ remote maps
     280
     281$ remote tuples are copied in line rather then jumping to the
     282$ main loop since we must set share bits in the tuple.
     283
     284$ allocate space for the set header and the tuple.
     285      len = hl_rmap + tuplen(oldp +hl_rmap);
     286
     287      get_heap(len, newp);    $ get new block
     288
     289$ copy set and tuple headers
     290      do j = 0 to (hl_rmap + hl_tuple) - 1;
     291          heap(newp+j) = heap(oldp+j);
     292      end do;
     293
     294$ copy tuple elements, setting share bits.
     295      do j = 0 to maxindx(oldp + hl_rmap);
     296          is_shared_ tcomp(oldp + hl_rmap, j) = yes;
     297          tcomp(newp + hl_rmap, j) = tcomp(oldp + hl_rmap, j);
     298      end do;
     299
     300      value_ copy1 = newp;  $ save new value_
     301
     302      go to done;
     303
     304/sc(h_lpmap)/                $ local packed map
     305
     306/sc(h_limap)/          $ local integer map
     307
     308/sc(h_lrmap)/                  $ local real map
     309
     310      call err_fatal(34);
     311
     312/sc(h_rpmap)/               $ remote packed map
     313
     314$ get length and jump to main loop
     315      len = hl_rpmap + ptuplen(oldp + hl_rpmap);
     316      go to loop;
     317
     318/sc(h_rimap)/           $ remote integer map
     319
     320
     321/sc(h_rrmap)/          $ remote real map
     322
     323$ get length and jump to main loop
     324      len = hl_rmap + tuplen(oldp +hl_rmap);
     325      go to loop;
     326
     327
     328/loop/     $ main copy loop
     329
     330$ this loop handles all cases where we simply make a word for word copy
     331$ of the old data block. oldp points to the old data block, and len
     332$ is its length.
     333
     334      get_heap(len, newp);
     335
     336      do j = 0 to len-1;
     337          heap(newp+j) = heap(oldp+j);
     338      end do;
     339
     340      value_ copy1 = newp;     $ save new value_
     341
     342      go to done;
     343
     344
     345
     346/done/                        $ save statistics and return
     347
     348 .+st save_time(st_copy);
     349
     350
     351      end fnct copy1;
       1 .=member locate
       2      subr locate(pos, x, s, add);
       3
       4$ this  routine searches the hash table of 's' for the element 'x',
       5$ and returns a pointer to the element block of 'x'.   if the 'add'
       6$ parameter is set,  we add 'x' to 's' if it is not found.   other-
       7$ wise we return a pointer to the template block of 's'.
       8
       9$ locate has  various auxilliary  outputs which  are not  needed by
      10$ every caller.  these are:
      11$
      12$ loc_found:     indiates whether 'x' was found in 's'.
      13$ loc_prev:      pointer to the previous element block in 's'.
      14$ loc_hash:      the hash code calculated for 'x'.
      15$
      16$ 'loc_prev' is used  to delete an element  from a clash list,  and
      17$ can be left undefined in certain cases:
      18$
      19$ 1. 's' is a base,  since only the garbage collector  deletes base
      20$    elements.
      21$
      22$ 2. 'x' is om, since we never delete om.
      23$
      24$ locate will expand the hash table when necessary.
      25
      26
      27      size pos(ps);           $ pointer returned
      28      size x(hs);             $ value specifier
      29      size s(ps);             $ pointer to set header
      30      size add(1);            $ assert on exit: x in s
      31
      32      size e(hs);             $ set element
      33      size fm1(ps);           $ base form of 'x' if 'x' is 'elmt b1'
      34      size fm2(ps);           $ form of 's'
      35      size ht(ps);            $ pointer to hash table of s
      36      size tmp(ps);           $ pointer to template block of s
      37      size log(ps);           $ log of hash header number
      38      size head(ps);          $ pointer to hash header
      39
      40      size gethash(hcsz);     $ computes hash code
      41      size equal(1);          $ top level equality routine
      42      size fval(hs);          $ tests based set membership
      43
      44
      45      loc_prev  = 0;
      46      loc_found = yes;
      47$
      48$ when the library is running with full error detection we will
      49$ sometimes call the locate routine to do locates in plex bases.
      50$
      51$ we are doing a locate in a plex base if and only if 's' has a
      52$ zero hashtb field.  in this case x must already be an element
      53$ of the base, and we merely return a pointer to it. (this is a
      54$ result of various restrictions on plex bases enforced by  the
      55$ compiler)
      56$
      57      if hashtb(s) = 0 then
      58          loc_hash = 0;       $ not needed
      59          pos      = value_ x;
      60
      61          return;
      62      end if;
      63$
      64$ if 'x' has the form 'elmt b1', and 's' happens to be the base b1,
      65$ then there is no need to do a hashed search  since 'x' points  to
      66$ the proper element base block.
      67$
      68      $ determine whether 'x' has the form 'elmt b1'
      69      if (otype_ x ^= t_elmt) go to search;
      70      pos = value_ x;   if (htype(pos) ^= h_ebb) go to search;
      71
      72      loc_hash = ebhash(pos);
      73
      74      $ check whether 'x' is 'elmt b1', 's' is base b1
      75      fm1 = ebform(pos);   fm2 = hform(s);
      76      if (fm1 = fm2) return;
      77
      78      if ( ^ is_based(s))     go to search;
      79      if (fm1 = ft_base(fm2)) return;
      80
      81
      82/search/                      $ do hashed search
      83$
      84$ at this point  we must search  the appropriate clash list of 's',
      85$ looking for 'x'.   we assume that 'x' can be found,  and  advance
      86$ 'pos' over  the clash list.   if we find 'x',  we return.   if we
      87$ fall through the loop, 'x' is not in the set.
      88$
      89$ 'loc_prev' is usually set at the bottom of the loop.   we initia-
      90$ lize it to point to the hash header to handle the case where  'x'
      91$ is the first element block on the clash list.
      92$
      93      init_probe(x, s, loc_hash, head);
      94
      95      loc_prev = head;
      96
      97      probe_loop(pos, head);
      98
      99          e = ebspec(pos);
     100
     101          if (eq(x, e)) return;
     102          if ^ ne(x, e) then
     103              if (equal(x, e)) return;
     104          end if;
     105
     106          loc_prev = pos;     $ save pointer to previous element
     107
     108      end_probe;
     109
     110
     111/not_found/
     112$
     113$ 'x' is not in the set:  add it if desired, otherwise return a
     114$ pointer to the template block so that 'f(x)' yields 'om'.
     115$
     116      loc_found = no;         $ flag not found
     117
     118      if add then
     119          call augment(head, x, s, loc_hash);   pos = head;
     120      else
     121          pos = template(s);
     122      end if;
     123
     124
     125      end subr locate;
       1 .=member insert
       2      subr insert(pos, x, s);
       3
       4$ this routine inserts an element into the hash table and returns
       5$ a pointer to it. like 'locate' it is a very low level primitive
       6$ however unlike locate, it assumes that x is not already in the set.
       7
       8      size pos(ps),  $ pointer returned
       9           x(hs),     $ specifier for element
      10           s(ps);     $ pointer to set header
      11
      12      size hashc(hcsz),  $ hash code of x
      13           head(ps);  $ pointer to hash header
      14
      15      size gethash(hcsz);  $ function called
      16
      17
      18      init_probe(x, s, hashc, head);   $ get pointer to hash header
      19
      20      call augment(head, x, s, hashc);  $ add element
      21      pos = head;
      22
      23
      24      end subr insert;
       1 .=member augment
       2      subr augment(pos, x, s, hashc);
       3
       4$ this routine performs the  actual list manipulation of  inserting
       5$ 'x' into 's'.
       6
       7$ augment is the lowest level routine for hash table insertion.  it
       8$ assumes that some higher level routine has  already performed the
       9$ necessary hashing.
      10
      11$ 'hashc' is the hash code of 'x'.  it is only used when augmenting
      12$ bases, and can be invalid in other cases.
      13$ this might well be under review, since our implementation of
      14$ iterators made it necessary to keep base sets sorted by their
      15$ element hash codes.  it probably would be better to always
      16$ require 'hashc' to be valid, and furthermore to always store
      17$ the hash code in the element block (this, too, is only  done
      18$ for bases).
      19
      20
      21      size pos(ps);           $ ptr to hash header, then to eb of x
      22      size x(hs);             $ specifier for new element
      23      size s(ps);             $ pointer to set header
      24      size hashc(ps);         $ hash of x
      25
      26      size ht(ps);            $ pointer to hash table
      27      size tmp(ps);           $ pointer to template block
      28      size head(ps);          $ pointer to hash header
      29      size ebsz(ps);          $ element block size
      30      size isb(1);            $ indicates that we process a base
      31      size fm(ps);            $ form of base
      32      size lim(ps);           $ maximum ebindx for constant base
      33      size indx(ps);          $ eb index of template
      34      size p1(ps);            $ misc. pointer
      35      size p2(ps);            $ misc. pointer
      36      size j(ps);             $ loop index
      37
      38
      39$
      40$ make sure we are not inserting omega.
      41$
      42      if is_om_ x then
      43          call err_om(14);
      44          return;
      45      end if;
      46$
      47$ get pointers to hash table header, template block, and hash header
      48$
      49      ht   = hashtb(s);
      50      tmp  = template(s);
      51      head = pos;
      52      isb  = (htype(tmp) = h_ebb);
      53$
      54$ allocate and initialize a new element block for 'x'.
      55$
      56      ebsz = ebsize(tmp);   get_heap(ebsz, pos);
      57
      58      $ set the new element block to match the template block
      59      do j = 0 to ebsz-1;
      60          heap(pos+j) = heap(tmp+j);
      61      end do;
      62
      63      $ set the proper flags
      64      is_ebtemp(pos) = no;
      65      is_ebhedr(pos) = no;
      66
      67      if isb then
      68          $
      69          $ we keep clash lists of bases sorted  in ascending order
      70          $ of their hash codes.   this means that we have to do  a
      71          $ little extra work here.
      72          $
      73          p1 = head;   p2 = eblink(p1);
      74          while ^ is_ebhedr(p2);
      75              if (ebhash(p2) > hashc) quit while;
      76
      77              p1 = p2;   p2 = eblink(p2);
      78          end while;
      79
      80          eblink(pos) = p2;
      81          eblink(p1)  = pos;
      82
      83      else   $ add as first element of clash list
      84          eblink(pos)  = eblink(head);
      85          eblink(head) = pos;
      86      end if;
      87$
      88$ insert 'x' into the element block
      89$
      90      is_shared_ x = yes;   ebspec(pos) = x;
      91$
      92$ save additional information for bases
      93$
      94      if isb then
      95          $ increment and  assign base index.   make sure  there is
      96          $ enough space between the stack and heap to do base com-
      97          $ paction.
      98
      99          indx = ebindx(tmp);
     100          if (indx = max_ebindx) call err_fatal(35);
     101
     102          if (min_gap < gb_space(indx)) min_gap = gb_space(indx);
     103
     104          $ if this is a constant base, make sure we are not inser-
     105          $ ting too many elements.
     106
     107          fm = ebform(pos);   lim = ft_lim(fm);
     108
     109          if lim ^= 0 then   $ constant base
     110              if (indx > lim) call err_fatal(36);
     111          end if;
     112
     113          ebindx(pos) = indx;
     114          ebindx(tmp) = indx+1;
     115
     116          ebhash(pos) = hashc; $ store hash code
     117      end if;
     118$
     119$ increment the number of element blocks in the set.  any necessary
     120$ adjustment to the 'nelt' field is handled by the caller.
     121$
     122      neb(ht) = neb(ht)+1;
     123
     124      mayexpand(s);
     125
     126
     127      end subr augment;
       1 .=member delete
       2      subr delete(s, prev, e, rehash);
       3
       4
       5$ this routine deletes an element block from a set. its arguments are:
       6
       7$ s:      pointer to set header
       8$ e:      pointer to eb being deleted
       9$ prev:   pointer to some eb which comes before 'e' in the set
      10$ rehash: indicates that we should try to contract set after deletion
      11
      12$ prev may point either to the eb immediately before 'e' or to
      13$ an eb considerably earlier. it is only used as the starting
      14$ point for loop which sets 'prev1' to point to the eb immediately
      15$ before 'e'. prev may even be 0, in which case we start the loop
      16$ with prev1 pointing to the template.
      17
      18$ we assume that 'delete' does not change the eblink of the block it
      19$ is deleting.
      20
      21
      22      size s(ps),     $ pointer to set
      23           prev(ps),   $ pointer to some previous eb
      24           e(ps),     $ pointer to element to be deleted
      25           rehash(1); $ on if rehashing allowed
      26
      27      size j(ps),       $ loop index
      28           ht(ps),      $ pointer to hash table
      29           tmp(ps),  $ pointer to template block
      30           nxt(ps),  $ pointer to next eb
      31           prev1(ps);  $ pointer to immediately previous eb.
      32
      33
      34
      35      if (is_ebtemp(e)) return;  $ never delete template
      36
      37      ht  = hashtb(s);        $ pointer to hash table
      38      tmp = template(s);      $ pointer to template block
      39      nxt = eblink(e);        $ pointer to next element block
      40
      41      prev1 = prev;           $ copy parameter
      42      if (prev1 = 0) prev1 = tmp;  $ worst case: start with template
      43
      44      while eblink(prev1) ^= e;  $ find immediate predecessor
      45          prev1 = eblink(prev1);
      46      end while;
      47
      48      eblink(prev1) = nxt;    $ link immediate predecessor to successor
      49
      50      neb(ht) = neb(ht)-1;   $ decrement number of block
      51
      52      if rehash then
      53          maycontract(s);
      54      end if;
      55
      56
      57      end subr delete;
       1 .=member nullset
       2      fnct nullset(form, n);
       3
       4$ this routine builds a null set and returns a specifier for it. its
       5$ arguments are:
       6
       7$ form:     the form of the desired set
       8$ n:        expected size of set
       9
      10$ we use 'form' to get a pointer to the omega value for the set and
      11$ then use the omega to build the null set.
      12
      13
      16      size nullset(hs);   $ specifier returned
      17
      18      size form(ps),  $ form of set
      19           n(ps);     $ indication of initial set size
      20
      21      size old(ps),  $ pointer to omega set
      22           new(ps);  $ pointer to null set
      23
      24      size tp(ps);  $ their htype
      25
      26      size i(ps),    $ loop indices
      27           j(ps);
      28
      29      size logn(ps),     $ log number of hash headers
      30           nhedr(ps),      $ number of hash headers
      31           total(ps),      $ total words needed for hash table
      32           ht(ps),   $ pointer to hash table of sample
      33           ebsz(ps),  $ its ebsize
      34           newht(ps),    $ pointer to new hash table
      35           tmp(ps),  $ pointer to template block of sample
      36           ntmp(ps),     $ pointer to template of nullset
      37           last(ps),    $ pointer to last hash header of null set
      38           eb(ps);     $ pointer to current eb.
      39
      40      size bit(ps),     $ ls_bit for local set
      41           word(ps);   $ ls_word
      42
      43      size p(ps);  $ misc. pointer
      44
      45      size om_val(hs),     $ om image of local map
      46           e(ps);       $ pointer to base element
      47
      48      size org(ps),      $ bit origin for local packed maps
      49           len(ps);     $ length of local packed value
      50
      51      size tup(hs);  $ specifier for null tuple
      52
      53      size nulltup(hs);  $ function called
      54
      55
      59$ initialize set header
      60
      61      old = value(ft_samp(form));
      62      tp = htype(old);
      63
      64$ copy set header
      65
      66      get_heap(hl(tp), new);
      67
      68      do j = 0 to hl(tp)-1;
      69          heap(new+j) = heap(old+j);
      70      end do;
      71
      72$ branch on type of set.
      73
      74      go to case(tp) in h_uset to h_lrmap;
      75
      76
      77
      78/case(h_uset)/   $ unbased sets and maps
      79
      80/case(h_umap)/
      81$
      82$ allocate a template block, hash table header, and hash table.
      83$
      84$ the hash table is built to hold n elements.  in order to keep the
      85$ density of the hash table correct, we allocate ceil(n/2) hash
      86$ headers.
      87$
      88      ht    = hashtb(old);      $ pointer to hash table of sample value
      89      ebsz  = ebsize(ht+hl_ht); $ element block size of sample value
      90      logn  = .fb. (n/2);       $ log number of new hash headers
      91      nhedr = pow2(logn);       $ number of new hash headers
      92
      93      total = hl_ht + ebsz + nhedr * hl_htb;
      94      get_heap(total, newht);
      95$
      96$ initialize hash table header
      97$
      98      hashtb(new) = newht;
      99
     100      htype(newht)     = h_ht;
     101      hlink(newht)     = 0;
     102      lognhedrs(newht) = logn;
     103      neb(newht)       = 0;
     104$
     105$ initialize template block
     106$
     107      tmp  = ht + hl_ht;     $ pointer to template of sample
     108      ntmp = newht + hl_ht;  $ pointer to new template block.
     109
     110      do i = 0 to ebsz-1;
     111          heap(ntmp+i) = heap(tmp+i);
     112      end do;
     113
     114      eblink(ntmp) = ntmp + ebsz;  $ pointer to first hash header
     115$
     116$ initialize hash table
     117$
     118      last = ntmp + ebsz + (nhedr-1)*hl_htb;  $ last hash header
     119
     120      do eb = ntmp+ebsz to last by hl_htb;
     121          htype(eb)     = h_htb;
     122          hlink(eb)     = 0;
     123          is_ebhedr(eb) = yes;
     124          is_ebtemp(eb) = no;
     125          eblink(eb)    = eb + hl_htb;
     126      end do;
     127
     128      eblink(last) = ntmp;  $ link last htb to template
     129
     130      if tp = h_uset then
     131          build_spec(nullset, t_set, new);
     132      else
     133          build_spec(nullset, t_map, new);
     134      end if;
     135
     136      return;
     137
     138
     139/case(h_lset)/         $ local based set
     140
     141$ iterate through set, clearing bits.
     142
     143      bit = ls_bit(new);
     144      word = ls_word(new);
     145
     146      next_loop(e, new);
     147          .f. bit, 1, heap(e+word) = 0;
     148      end_next;
     149
     150      build_spec(nullset, t_set, new);
     151
     152      return;
     153
     154
     155/case(h_rset)/        $ remote based set
     156
     157$ fill in rs_maxi then allocate a bit string for the remote set.
     158$ since these bit strings are zero origined, rs_maxi will always
     159$ be 1 less than a multiple of rs_bpw. if particular, if k is
     160$ the floor of n/ps_bpw it will be k * rs_bpw + (rs_bpw-1).
     161
     162$ 'rswords(new)' gives the number of words in the sets
     163$ bit string. this is determined from the sets rs_maxi, which
     164$ must be filled in first.
     165
     166      rs_maxi(new) = (n/rs_bpw) * rs_bpw + (rs_bpw-1);
     167
     168      get_heap(rswords(new), p);
     169
     170      do j = 1 to rswords(new);
     171          rsword(new, j) = 0;
     172      end do;
     173
     174      build_spec(nullset, t_set, new);
     175
     176      return;
     177
     178
     181/case(h_rmap)/        $ remote maps
     182
     183/case(h_rpmap)/
     184
     185/case(h_rrmap)/
     186
     187/case(h_rimap)/
     188
     189
     190$ remote maps are processed in two steps:
     191
     192$ 1. allocate a null tuple of the appropriate type. this is given
     193$    by ft_tup(form).
     194
     195$ 2. if this is an mmap, iterate over the components of the tuple,
     196$    clearing their is_im bits and setting their is_multi bits.
     197
     198      tup = nulltup(ft_tup(form), n);
     199
     200      if is_mmap(new) then
     201          p = value_ tup;
     202
     203          do j = 0 to maxindx(p);
     204              is_multi_ tcomp(p, j) = yes;
     205              is_om_   tcomp(p, j) = no;
     206          end do;
     207      end if;
     208
     209      build_spec(nullset, t_map, new);
     210
     211      return;
     212
     213
     214/case(h_lmap)/      $ local based maps
     215
     216/case(h_limap)/
     217
     218/case(h_lrmap)/
     219
     220$ set images to template block
     221
     222      word = ls_word(new);   $ get eb word
     223
     224      om_val = heap(template(new)+word);  $ get om image
     225
     226      next_loop(e, new);
     227          heap(e+word) = om_val;
     228      end_next;
     229
     230      build_spec(nullset, t_map, new);
     231
     232      return;
     233
     234
     236/case(h_lpmap)/    $ local packed map
     237
     238$ set images to 0.
     239
     240      org = ls_bit(new);  $ bit origin in word
     241      len = ls_bits(new);  $ length of field to clear
     242      word = ls_word(new);  $ word offset
     243
     244      next_loop(e, new);
     245          .f. org, len, heap(e+word) = 0;
     246      end_next;
     247
     248      build_spec(nullset, t_map, new);
     249
     250      return;
     251
     252      end fnct nullset;
       1 .=member nulltup
       2      fnct nulltup(form, n);
       3
       4$ this routine builds a null tuple of alloc -n- from a form
       5$ and returns a pointer to it.
       6
       7
      10      size nulltup(hs);     $ specifier for tuple returned
      11
      12      size form(ps),  $ form for tuple tuple
      13           n(ps);     $ initial size
      14
      15      size old(ps),  $ pointer to standard omega tuple
      16           new(ps);  $ pointer to new tuple
      17
      18      size j(ps),     $ loop index
      19           tp(ps),  $ type of tuple
      20           maxi(ps),   $ maximum index for tuple.
      21           alloc(ps),  $ total allocation
      22           scomp(hs),     $ specifier for sample component
      23           spec(hs);   $ specifier passed to copy routine
      24
      25
      28      old = value(ft_samp(form));
      29
      30
      31$ branch on type
      32
      33      tp = htype(old);
      34      go to case(tp) in h_tuple to h_rtuple;
      35
      36
      37/case(h_tuple)/      $ standard tuples
      38
      39$ special case mixed tuples
      40
      41      if (ft_type(hform(old)) = f_mtuple) go to mtuple;
      42
      43
      44/case(h_rtuple)/     $ real and integer tuples
      45
      46/case(h_ituple)/
      47
      48$ determine the maximum index for the tuple, then find the
      49$ number of words to allocate.
      50
      51      maxi = n + breath_space(n);
      52      if (maxi < ft_lim(form)) maxi = ft_lim(form);
      53      alloc = talloc(maxi);
      54
      55      get_heap(alloc, new);  $ allocate space
      56
      57      do j = 0 to hl_tuple-1;  $ initialize tuple header
      58          heap(new+j) = heap(old+j);
      59      end do;
      60
      61      maxindx(new) = maxi;  $ store maximum index
      62
      63$ get sample component from old(0) and initialize null tuple.
      64      scomp = tcomp(old, 0);  $ sample component
      65
      66      do j = 0 to maxi;
      67          tcomp(new, j) = scomp;
      68      end do;
      69
      70      if tp = h_tuple then
      71          build_spec(nulltup, t_tuple, new);
      72      else
      73          build_spec(nulltup, t_stuple, new);
      74      end if;
      75
      76      return;
      77
      78
      79/case(h_ptuple)/          $ packed tuples
      80
      81$ find maximum index and total length of tuple
      82      maxi = n + breath_space(n);
      83      if (maxi < ft_lim(form)) maxi = ft_lim(form);
      84      alloc = palloc(old, maxi);
      85
      86      get_heap(alloc, new);
      87
      88      do j = 0 to hl_ptuple-1;  $ initialize header
      89          heap(new+j) = heap(old+j);
      90      end do;
      91
      92      maxindx(new) = maxi;
      93
      94$ set components to 0, a word at a time.
      95      do j = hl_ptuple to alloc-1;
      96          heap(new+j) = 0;
      97      end do;
      98
      99      build_spec(nulltup, t_stuple, new);
     100
     101      return;
     102
     103
     106/mtuple/      $ mixed tuples
     107
     108$ for mixed tuples, we return a copy of the sample, with the
     109$ is_om bits of its components set. when we make the copy
     110$ we do not set the share bits of the components. this is
     111$ safe since no correct program will destructively use an om.
     112
     113      maxi = maxindx(old); $ get maximum index and length.
     114      alloc = talloc(maxi);
     115
     116      get_heap(alloc, new); $ allocate new tuple
     117
     118      do j = 0 to hl_tuple-1;  $ initialize header
     119          heap(new+j) = heap(old+j);
     120      end do;
     121
     122      do j = hl_tuple to alloc-1;  $ copy components
     123          heap(new+j) = heap(old+j);
     124          is_om(new+j) = yes;
     125      end do;
     126
     127      build_spec(nulltup, t_tuple, new);
     128
     129      return;
     130
     131
     132      end fnct nulltup;
       1 .=member nulllc
       2      fnct nulllc(n);
       3
       4$ this routine allocates a long character block large enough to hold
       5$ -n- characters, and returns a string specifier whose ss_len
       6$ indicates a null string and whose ss_ptr points to the the block.
       7
       8
       9      size nulllc(ssz);
      10
      11      size n(ps);   $ number of characters to fit in block.
      12
      13      size p(ps);   $ pointer to long character data block
      14
      15
      16$ before allocating a long character string block, we build
      17$ a string specifier with zero fields. if string specifiers are
      18$ being stored indirectly, building the specifier will allocate
      19$ a heap block. we build the string specifier before allocating
      20$ the long character data block. this means the long character block
      21$ will be the last thing allocated on the heap, and can be expanded
      22$ more efficiently.
      23
      24      build_ss(nulllc, 0, 0, 0);
      25
      26      get_heap(lcalloc(n), p);
      27
      28      htype(p) = h_lstring;  $ initialize header
      29      hlink(p) = 0;
      30      lc_nwords(p) = lcalloc(n);
      31
      32      ss_ptr(nulllc) = p;  $ point to long chars block
      33
      34
      35      end fnct nulllc;
       1 .=member rset1
       2      fnct rset1(el);
       3
       4$ this function builds the singleton set @el\. it is used
       5$ primarily when we are taking f@x\ at a point where f is
       6$ single valued or undefined.
       7
       8$ if 'el' is a pair, we return an unbased map; otherwise
       9$ we return an unbased set.
      10
      11
      12      size el(hs);   $ specifier for element
      13
      14      size rset1(hs);  $ specifier for set returned
      15
      16      size p(ps),    $ pointer to pair
      17           hd(hs),   $ head of pair
      18           tl(hs),   $ tail of pair
      19           s(ps),   $ pointer to result
      20           pos(ps);  $ pointer returned by locate routine
      21
      22      size nullset(hs);  $ function called
      23
      24
      25$ seperate map and set cases
      26
      27      if (type_ el ^= t_tuple) go to set;
      28
      29      p = value_ el;
      30      if (nelt(p) ^= 2) go to set;
      31      if (is_om_ tcomp(p, 1)) go to set;
      32
      33
      34/map/       $ build map
      35
      36      rset1 = nullset(f_umap, 1);
      37      s     = value_ rset1;
      38
      39      if ^ is_om_ el then  $ insert el
      40          hd = tcomp(p, 1);
      41          tl = tcomp(p, 2);
      42
      43          call insert(pos, hd, s);
      44          call sfval(s, pos, tl);
      45
      46          set_nelt(s, 1);
      47      end if;
      48
      49      return;
      50
      51
      52/set/       $ build set
      53
      54      rset1 = nullset(f_uset, 1);
      55      s     = value_ rset1;
      56
      57      if ^ is_om_ el then   $ insert el
      58          call insert(pos, el, s);
      59          set_nelt(s, 1);
      60      end if;
      61
      62      return;
      63
      64
      65      end fnct rset1;
      66      fnct rset2(e1, e2);
      67
      68$ this function builds the set @e1, e2\ so that it can be stored
      69$ as the image of a map. e1 and e2 are known to be non-om and
      70$ unequal.
      71
      72$ if e1 and e2 are both pairs, we build an unbased map; otherwise
      73$ we build an unbased set. the routine is recursive, since e1 and
      74$ e2 may be pairs with the same head, in which case their image
      75$ will be the set containing their tails.
      76
      77
      78      size e1(hs),   $ specifiers for elements
      79           e2(hs);
      80
      81      size rset2(hs);   $ specifier for set returned
      82
      83      size a1(hs),   $ arguments to recursive routine
      84           a2(hs);
      85
      86      size tstart(ps);  $ initial pointer to top of stack
      87
      88      size pos(ps);  $ pointer returned by 'insert'.
      89
      90      size nullset(hs),  $ functions called
      91           equal(1);
      92
      93$ stacked variables
      94
      95 .=zzyorg b    $ reset counter for local variables
      96
      97      local(st);  $ specifier for set returned
      98      local(s);  $ pointer to it
      99
     100      local(p1);    $ pointers to pairs
     101      local(p2);
     102
     103      local(hd1);   $ components of pairs
     104      local(tl1);
     105
     106      local(hd2);
     107      local(tl2);
     108
     109      local(retpt);  $ return pointer
     110
     111
     112      a1 = e1;   $ make local copies of arguments
     113      a2 = e2;
     114
     115      tstart = t;  $ save pointer to top of stack
     116
     117 .=zzyorg a  $ reset counter for return labels
     118
     119/entry/      $ recursive entry point
     120
     121      r_entry;
     122
     123$ seperate set and map cases
     124
     125      if (type_ a1 ^= t_tuple ! type_ a2 ^= t_tuple) go to set;
     126
     127      p1 = value_ a1;   $ get pointers to tuples
     128      p2 = value_ a2;
     129
     130      if (nelt(p1) ^= 2 ! nelt(p2) ^= 2) go to set;
     131      if (is_om_ tcomp(p1, 1) ! is_om_ tcomp(p2, 1)) go to set;
     132
     133
     134/map/         $ build map
     135
     136$ allocate a null map, then branch to either 'match' or 'nomatch'
     137$ depending on whether the pairs have matching heads.
     138
     139      st = nullset(f_umap, 2);
     140      s = value_ st;
     141
     142      hd1 = tcomp(p1, 1);   $ take apart tuples
     143      tl1 = tcomp(p1, 2);
     144
     145      hd2 = tcomp(p2, 1);
     146      tl2 = tcomp(p2, 2);
     147
     148      if eq(hd1, hd2) then
     149          go to match;
     150
     151      elseif ne(hd1, hd2) then
     152          go to nomatch;
     153
     154      elseif equal(hd1, hd2) then
     155          go to match;
     156
     157      else
     158          go to nomatch;
     159      end if;
     160
     161
     162/match/    $ heads match
     163
     164$ we will insert hd1 into the domain of s, and set its
     165$ image to the set @tl1, tl2\. we begin by forming
     166$ this doubleton set. this of course requires a recursive
     167$ call.
     168
     169      a1 = tl1;
     170      a2 = tl2;
     171
     172      r_call;
     173
     174      is_multi_ rset2 = yes;
     175
     176      call insert(pos, hd1, s);  $ insert hd1 and set its image.
     177      call sfval(s, pos, rset2);
     178
     179      set_nelt(s, 2);
     180      rset2 = st;
     181
     182      go to exit;
     183
     184
     185/nomatch/   $ heads dont match
     186
     187$ insert both pairs in the map.
     188
     189      call insert(pos, hd1, s);
     190      call sfval(s, pos, tl1);
     191
     192      call insert(pos, hd2, s);
     193      call sfval(s, pos, tl2);
     194
     195      set_nelt(s, 2);
     196      rset2 = st;
     197
     198      go to exit;
     199
     200
     201/set/      $ build set
     202
     203      st = nullset(f_uset, 2);
     204      s   = value_ st;
     205
     206      call insert(pos, a1, s);
     207      call insert(pos, a2, s);
     208
     209      set_nelt(s, 2);
     210      rset2 = st;
     211
     212      go to exit;
     213
     214
     215/exit/      $ recursive exit point
     216
     217      r_exit;
     218
     219      if t ^= tstart then  $ recursive return
     220          go to rlab(retpt) in 1 to zzya;
     221      else
     222          return;
     223      end if;
     224
     225      macdrop8(s, p1, p2, hd1, tl1, hd2, tl2, retpt)
     226      macdrop(st)
     227
     228      end fnct rset2;
       1 .=member rset2
       1 .=member setform
       2      fnct setform(form, n);
       3
       4$ this is the general set former. n is the number of elements, and
       5$ 'form' is a form value for the result.
       6
       7$ the elements are passed through the stack and popped when we are done.
       8$ they are assumed to already have the proper type.
       9
      10
      11      size setform(hs);    $ specifier returned
      12
      13      size form(ps),  $ form of set
      14           n(ps);       $ number of elements
      15
      16      size el(hs),  $ set element
      17           j(ps);     $ loop index
      18
      19      size nullset(hs),  $ functions called
      20           withs(hs);
      21
      22
      23$ we begin by allocating a null set of the proper size and type,
      24$ then iterate over the elements calling 'withs'.
      25
      26      setform = nullset(form, n);
      27
      28      do j = 1 to n;
      29          el = stack_arg(j, n);
      30          setform = withs(setform, el, yes);
      31      end do;
      32
      33      free_stack(n);
      34
      35
      36      end fnct setform;
       1 .=member setf1
       2      fnct setf1(n);
       3
       4$ this routine is similar to the general purpose setformer
       5$ above, but is used when we do not know at compile time
       6$ whether we would like the result to be a set or a map.
       7$ if all the elements of the set turn out to be pairs, we
       8$ will generate a map; otherwise we will generate a set.
       9
      10
      11      size n(ps);   $ number of elements in set
      12
      13      size setf1(hs);  $ specifier returned
      14
      15      size j(ps),   $ loop index
      16           el(hs);  $ set element
      17
      18      size setform(hs);  $ general setformer
      19
      20
      21      do j = 1 to n;
      22          el = stack_arg(j, n);
      23
      24          if (otype_ el ^= t_tuple) go to set;
      25          if (nelt(value_ el) ^= 2) go to set;
      26          if (is_om_ tcomp(value_ el, 1)) go to set;
      27      end do;
      28
      29/map/     $ build unbased map
      30
      31      setf1 = setform(f_umap, n);
      32      return;
      33
      34/set/    $ build set
      35
      36      setf1 = setform(f_uset, n);
      37      return;
      38
      39      end fnct setf1;
       1 .=member tupform
       2      fnct tupform(form, n);
       3
       4$ this routine builds a tuple. the components are passed through
       5$ the stack, and are assumed to have the proper type. we begin
       6$ by building a null tuple, then iterate over the components,
       7$ popping them and putting them into the tuple.
       8
       9
      10      size form(ps),          $ form of tuple
      11           n(ps);             $ number of elements
      12
      13      size tupform(hs);       $ specifier returned
      14
      15      size p(ps),             $ pointer to nulltup
      16           j(ps),             $ loop index
      17           el(hs),            $ specifier for tuple element
      18           tp(ps),            $ type of tuple
      19           nel(ps),           $ nelt of tuple
      20           omval(hs);         $ omega value
      21      size key(hs);           $ pack key for packed tuple
      22      size indx(ps);          $ pack index for packed tuple
      23
      24      size nulltup(hs);       $ function called
      25
      26
      27      tupform = nulltup(form, n);
      28      p       = value_ tupform;
      29
      30      go to case(htype(p)) in h_tuple to h_rtuple;
      31
      32
      33/case(h_tuple)/    $ standard tuple
      34
      35      nel = 0;  $ nelt of tuple
      36
      37      do j = 1 to n;
      38          el = stack_arg(j, n);
      39          if (^ is_om_ el) nel = j;  $ save index if defined
      40          tcomp(p, j) = el;
      41      end do;
      42
      43      nelt(p) = nel;
      44
      45      free_stack(n);
      46
      47      return;
      48
      49
      50/case(h_ptuple)/  $ packed tuples
      51
      52$ store components by offline calls to sof.
      53$ sof will adjust the nelt of the tuple as it goes.
      54
      55      key = ptkey(p);   nel = 0;
      56
      57      do j = 1 to n;
      58          el = stack_arg(j, n);
      59          if (^ is_om_ el) nel = j;
      60
      61          pack(key, indx, el);
      62          pcomp(p, j) = indx;
      63      end do;
      64
      65      nelt(p) = nel;
      66
      67      free_stack(n);  $ free space used by arguments
      68
      69      return;
      70
      71
      72/case(h_ituple)/     $ untyped tuples
      73
      74/case(h_rtuple)/
      75
      76$ the top 2n stack entries contain n untyped data words
      77$ sandwiched between n skip words.
      78
      79      omval = tcomp(p, 0);    $ omega value
      80      nel   = 0;
      81
      82      do j = 1 to n;
      83          el = stack_arg(2*j - 1, 2*n);
      84          if (el ^= omval) nel = j;
      85
      86          tcomp(p, j) = el;
      87      end do;
      88
      89      nelt(p) = nel;
      90
      91      free_stack(2*n);
      92
      93      return;
      94
      95
      96      end fnct tupform;
       1 .=member expand
       2      subr expand(ht);
       3
       4$ this routine expands the hash table for a set or base, rehashing
       5$ all its elements.
       6$
       7$ rehashing is always done in place.  we allocate a new hash table
       8$ and chain the eb's of the old hash table to it.  this leaves all
       9$ the hash headers of the new hash table unused.
      10
      11
      12      size ht(ps);            $ pointer to hash table
      13
      14      size nhedr(ps);         $ number of headers in new hash table
      15      size log(ps);           $ log of nhedr
      16
      17      size tmp(ps);           $ pointer to template block
      18      size first(ps);         $ pointer to first new hash header
      19      size last(ps);          $ pointer to last new hash header
      20      size eb(ps);            $ pointer to eb being initialized
      21      size i(ps);             $ loop index within current eb
      22
      23      size hashc(hcsz);       $ hash code of current eb
      24      size mask(hs);          $ mask used to restrict hash code
      25      size key(hs);           $ restricted hash code
      26      size head(ps);          $ pointer to new hash header
      27      size now(ps);           $ pointer to current element block
      28      size nxt(ps);           $ pointer to next element block
      29      size prev(ps);          $ pointer to element block before nxt
      30      size isb(1);            $ set if we expand a base
      31      size spec(hs);          $ element block specifier
      32
      33      size gethash(hcsz);     $ function called
      34
      35
      36      tmp   = ht + hl_ht;     $ pointer to template block
      37      isb   = (htype(tmp) = h_ebb);  $ flag base expansions
      38$
      39$ determine the size of the new hash table
      40$
      41      log   = lognhedrs(ht)+1;
      42
      43      if (log >= hcsz)     return;   $ maximum hash code used
      44      if (log >= max_logn) return;   $ maximum value for lognhedrs
      45
      46      mask  = onebits(log);
      47      nhedr = pow2(log);
      48$
      49$ allocate and initialize new hash table
      50$
      51      $ there is at least one place in the library ('withs'), where
      52      $ we assume that the re-allocation of the hash table does not
      53      $ cause a garbage collection.  the following test asserts this
      54      $ assumption.
      55      $ note that we call gethash, which is a recursive routine with
      56      $ 14 local variables.
      57      if ((t-h-(nhedr*hl_htb)-(max_depth*14)) < min_gap) return;
      58      get_heap(nhedr * hl_htb, first);
      59
      60      $ initialize each hash header to a copy of the template and
      61      $ link it to the next header.  link the last header to the
      62      $ template.
      63
      64      last = first + (nhedr-1) * hl_htb;
      65
      66      do eb = first to last by hl_htb;
      67          htype(eb)     = h_htb;
      68          hlink(eb)     = 0;
      69          eblink(eb)    = eb + hl_htb;
      70          is_ebhedr(eb) = yes;
      71          is_ebtemp(eb) = no;
      72      end do;
      73
      74      eblink(last) = tmp;     $ link last header to template
      75$
      76$ add elements of old hash table to clash lists.
      77$
      78      $ we iterate over the old hash table, inserting elements into
      79      $ the new hash table.  since we will be adjusting the eblinks
      80      $ of the elements as we go, we must use a variant of the nor-
      81      $ mal next_loop.
      82      $
      83      $ the variables used in this loop are:
      84      $
      85      $ now:    element currently being moved
      86      $ head:   hash header on which it will be inserted.
      87      $ nxt:    next element block to be moved.
      88
      89      now = eblink(tmp); $ point to first hash header of old hash table
      90
      91      while 1;
      92          if is_ebhedr(now) then
      93              if (is_ebtemp(now)) quit while 1;
      94
      95              now = eblink(now);
      96              cont while 1;
      97          end if;
      98$
      99$ find the proper hash header.  this code is similar to the code
     100$ in 'init_probe', with the exceptions that we assume that the
     101$ element had its hash calculated when it was inserted.  if the
     102$ element is itself a set or tuple, its hash field must still be
     103$ valid.
     104$
     105$ when we expand the hash table of a base, we can take advantage
     106$ of the fact that the clash lists are sorted in ascending hash
     107$ order, and that the hash code of each element is saved in the eb.
     108$
     109          if isb then
     110              hashc = ebhash(now);
     111
     112          else
     113              spec = ebspec(now);
     114
     115              if ^ isprim(type_ spec) then
     116                  hashc = hash(value_ spec);
     117              else
     118                  hashc = gethash(spec);
     119              end if;
     120          end if;
     121
     122          key  = hashc & mask;
     123          head = first + hl_htb * (.f. hcsz-log+1, log, key);
     124
     125          prev = now;   nxt = eblink(now);
     126
     127          if isb then
     128              while 2;
     129                  if (is_ebhedr(nxt)) quit while 2;
     130                  if (key ^= (ebhash(nxt) & mask)) quit while 2;
     131
     132                  prev = nxt;   nxt = eblink(nxt);
     133              end while 2;
     134          end if;
     135
     136          eblink(prev) = eblink(head);
     137          eblink(head) = now;
     138
     139          now = nxt;
     140      end while 1;
     141
     142      eblink(tmp)  = first;
     143
     144      lognhedrs(ht) = log;
     145
     146
     147      end subr expand;
       1 .=member contract
       2      subr contract(ht);
       3
       4$ this routine halfs the size of a hash table.   we reuse the first
       5$ half of the old hash table, combining each pair of clash lists of
       6$ the old hash table to one clash list in the new hash table.
       7
       8
       9      size ht(ps);            $ pointer to hash table
      10
      11      size tmp(ps);           $ pointer to template block
      12      size head(ps);          $ pointer to current new hash header
      13      size now(ps);           $ pointer to head of new clash list
      14      size prev(ps);          $ pointer to tail of old clash list
      15      size nxt(ps);           $ pointer to next old hash header
      16      size p(ps);             $ misc. pointer
      17
      18
      19      tmp  = ht + hl_ht;
      20      head = eblink(tmp);
      21$
      22$ iterate over the set,  combining clash lists  and re-linking  the
      23$ hash headers.
      24$
      25      nxt = head;
      26
      27      until is_ebtemp(nxt);
      28
      29          $ save potential start of new clash list
      30          now = eblink(nxt);
      31
      32          $ find the end of the even clash list
      33          prev = nxt;   nxt = now;
      34
      35          while ^ is_ebhedr(nxt);
      36              prev = nxt;   nxt = eblink(nxt);
      37          end while;
      38
      39          $ if the current clash list is null, then update 'now' to
      40          $ point to the head of the odd  clash list;  else  update
      41          $ the tail pointer of the even clash list to point to the
      42          $ head of the odd clash list.
      43          p = eblink(nxt);
      44          if now = nxt then now = p; else eblink(prev) = p; end if;
      45
      46          $ find the end of the odd clash list
      47          nxt = p;            $ skip old header
      48
      49          while ^ is_ebhedr(nxt);
      50              prev = nxt;   nxt = eblink(nxt);
      51          end while;
      52
      53          $ compute the pointer to the next hash header
      54          if nxt = tmp then p = tmp; else p = head + hl_htb; end if;
      55
      56          $ if the current clash list is null, then update 'now' to
      57          $ point to the next hash header;  else  update  the  tail
      58          $ pointer of the current clash  list to point to the next
      59          $ hash header.
      60          if now = nxt then now = p; else eblink(prev) = p; end if;
      61
      62          eblink(head) = now;   head = p;
      63
      64      end until;
      65$
      66$ update the log of the number of hash headers
      67$
      68      lognhedrs(ht) = lognhedrs(ht) - 1;
      69
      70
      71      end subr contract;
       1 .=member exptup
       2      subr exptup(tup, n);
       3
       4$ this routine rebuilds a tuple so that it has room for n elements.
       5$ tup is the specifier for the tuple. we assume that no share bits
       6$ need be set.
       7
       8
       9      size tup(hs),    $ specifier for tuple
      10           n(ps);   $ minimum new length
      11
      12      size p(ps),    $ pointer to tuple
      13           p1(ps),  $ pointer to new components
      14           newp(ps),   $ pointer to new tuple
      15           j(ps),      $ loop index
      16           om_val(hs),  $ om component
      17           extra(ps),  $ extra words needed for packed tuple
      18           maxi(ps),  $ currnet maximum index of tuple
      19           nmaxi(ps),   $ new maximum index
      20           len(ps);    $ its current length, including header
      21
      22
      23$ begin by getting a pointer to the tuple, and splitting out packed
      24$ tuples for special treatment.
      25
      26      p = value_ tup;
      27
      28      if (htype(p) = h_ptuple) go to packed;
      29
      30$ otherwise proceed with standard tuples. get current maximum index
      31$ and storage allocation, then see if the tuple was the last thing
      32$ allocated. if not, move it to the top of the heap.
      33
      34      maxi = maxindx(p);
      35      len = tuplen(p);
      36
      37      if p + len = h then  $ last thing allocated
      38          newp = p;
      39
      40      else  $ move to top of heap
      41          get_heap(len, newp);
      42
      43          do j = 0 to len-1;
      44              heap(newp+j) = heap(p+j);
      45          end do;
      46
      47          value_ tup = newp;   is_shared_ tup = no;
      48      end if;
      49
      50$ now get space for the new components and copy the template.
      51
      52      nmaxi = n + breath_space(n);   $ new maximum index
      53      get_heap(nmaxi-maxi, p1); $ allocate extra space
      54
      55      om_val = tcomp(newp, 0); $ initialize new components
      56
      57      do j = maxi+1 to nmaxi;
      58          tcomp(newp, j) = om_val;
      59      end do;
      60
      61      maxindx(newp) = nmaxi;  $ reset alloc.
      62
      63      return;
      64
      65
      66/packed/         $ packed tuples
      67
      68$ the algorithm for packed tuples is identical to the above,
      69$ except that we calculate block sizes, etc. using macros for
      70$ packed tuples.
      71
      72      maxi = maxindx(p);
      73      len = ptuplen(p);
      74
      75      if p + len = h then
      76          newp = p;
      77
      78      else
      79          get_heap(len, newp);
      80
      81          do j = 0 to len-1;
      82              heap(newp+j) = heap(p+j);
      83          end do;
      84
      85          value_ tup = newp;   is_shared_ tup = no;
      86      end if;
      87
      88$ now extend tuple in place
      89
      90      nmaxi = n + breath_space(n);
      91      extra = palloc(p, nmaxi) - palloc(p, maxi);
      92
      93      get_heap(extra, p1);
      94
      95      do j = 0 to extra-1;  $ zero out extra words.
      96          heap(p1+j) = 0;
      97      end do;
      98
      99      maxindx(newp) = nmaxi;  $ store new maximum index
     100
     101      return;
     102
     103
     104      end subr exptup;
       1 .=member explc
       2      subr explc(ss, n);
       3
       4$ this routine rebuilds a character string so that it has room
       5$ for -n- characters.
smfc  75
smfc  76
smfc  77      size ss(ssz);           $ string specifier
smfc  78      size n(ps);             $ new minimum length
smfc  79
smfc  80      size p(ps);             $ pointer to data block
smfc  81      size len(ps);           $ length of data block (in words)
smfc  82      size total(ps);         $ total allocation used (in characters)
smfc  83      size newss(ssz);        $ new string specifier
smfc  84      size new(ps);           $ pointer to new data block
smfc  85
smfc  86      size nulllc(ssz);       $ allocates null string
      26$ begin by checking whether we can extend the current string, or
      27$ whether we must build a new one. the current string can be
      28$ extended if
      29
      30$ 1. its at the end of a long character data block.
      31
      32$ 2. the data block was the last thing allocated.
      33
      34      p = ss_ptr(ss);  $ point to data block and get length
      35      len = lc_nwords(p);
      36
      37$ get total number of characters from start of block to the end of
      38$ the string. see if this equals the length of the block.
      39      total = ss_ofs(ss) + ss_len(ss);
      40
      41      if p+len = h & lcalloc(total) = len then $ reuse block
      42
      43          get_heap(lcalloc(n)-lc_nwords(p), new);  $ get extra block
      44          lc_nwords(p) = lcalloc(n);
      45
      46      else       $ get new block and copy
smfc  87          newss = nulllc(n);   ss_len(newss) = ss_len(ss);
      48
      49          mvc(newss, ss, ss_len(ss));
      50
      51          ss = newss;   $ return specifier for new ss
      52      end if;
      53
      54
      55      end subr explc;
       1 .=member exprmap
       2      fnct exprmap(map, n);
       3
       4$ this routine expands the tuple for a remote map. -map- is a pointer to
       5$ the map and -n- is the minimum size for the new tuple. a pointer
       6$ to the new map is returned.
       7
       8
      11      size exprmap(ps);   $ pointer to map returned
      12
      13      size map(ps),    $ pointer to original map
      14            n(ps);     $ new capacity of map
      15
      16      size spec(hs),   $ specifier for tuple contained in map
      17           tup(hs),  $ specifier for tuple
      18           len(ps),    $ current length of map
      19
      20           l(ps),  $ length of header
      21           p(ps),  $ pointer to tuple
      22           j(ps);      $ loop index
      23
      24
      28$ remote maps are expaned in three steps
      29
      30$ 1. build a specifier for the embedded tuple.
      31$ 2. copy the set header to the top of the heap if necessary
      32$ 3. call exptup to expand the embedded tuple.
      33
      34      l = hl(htype(map));
      35      p = map + l;
      36
      37      go to case(htype(p)) in h_tuple to h_rtuple;
      38
      39/case(h_tuple)/   $ standard tuple
      40
      41      build_spec(tup, t_tuple, p);
      42      len = l + tuplen(p);
      43      go to esac;
      44
      45/case(h_ptuple)/   $ packed tuple
      46
      47      build_spec(tup, t_stuple, p);
      48      len = l + ptuplen(p);
      49      go to esac;
      50
      51
      52/case(h_ituple)/   $ untyped tuples
      53
      54/case(h_rtuple)/
      55
      56      build_spec(tup, t_stuple, p);
      57      len = l + tuplen(p);
      58      go to esac;
      59
      60
      61/esac/    $ end of case
      62
      63$ see if the map is on top of the heap. if not, copy the set header.
      64
      65      if map+len = h then  $ on top of heap
      66          exprmap = map;
      67
      68      else                   $ move set header to top of heap
      69          get_heap(l, exprmap);
      70
      71          do j = 0 to l-1;
      72              heap(exprmap+j) = heap(map+j);
      73          end do;
      74      end if;
      75
      76      call exptup(tup, n);  $ move tuple on top of it.
      77
      79
      80      end fnct exprmap;
       1 .=member exprset
       2     fnct exprset(s, n);
       3
       4$ this routine expands a remote set. if the set is already on the
       5$ top of the heap, we expand it in place.
       6
       7
       8      size exprset(ps);   $ pointer to new set returned
       9
      10      size s(ps),  $ pointer to old set
      11           n(ps);    $ new capacity of set
      12
      13      size total(ps),  $ total length of new set
      14           len(ps),    $ length of old set
      15           extra(ps);  $ extra words needed
      16
      17      size p(ps),      $ pointer to new block
      18           j(ps);      $ loop index
      19
      20
      21      total = rsalloc(n);   $ length of new set
      22      len = rswords(s) + hl_rset;  $ current length
      23
      24      extra = total - len;  $ extra space needed
      25
      26      if s + len ^= h then $ copy s to top of heap
      27          get_heap(len, p);
      28
      29          do j = 0 to len-1;
      30              heap(p+j) = heap(s+j);
      31          end do;
      32
      33          exprset = p;
      34
      35      else     $ expand in place
      36          exprset = s;
      37      end if;
      38
      39$ allocate extra words and inialize to 0.
      40      get_heap(extra, p);
      41
      42      do j = 0 to extra-1;
      43          heap(p+j) = 0;
      44      end do;
      45$
      46$ finally set rs_maxi. since the bit strings in remote sets are
      47$ zero origined, this will always be one less than a multiple
      48$ of rs_bpw. in particular if k is the floor of n/rs_bpw it
      49$ will be k * rs_bpw + (rs_bpw-1).
      50$
      51      rs_maxi(exprset) = (n/rs_bpw)*rs_bpw + (rs_bpw-1);
      52
      53
      54      end fnct exprset;
      55 ..part3
       1 .=member gethash
       2 .+part4.
       3      fnct gethash(spec);
       4
       5$ this routine calculates the hash code corresponding to a given
       6$ specifier. it is recursive to handle the hash codes of sets,
       7$ maps and tuples.
       8
       9$ this routine is called in many inner loops and should be carefully
      10$ instrumented.
      11$ if the arguments form allows it, we set the objects is_hashok
      12$ bit once the hash is validated.
      13
      14$ it is inexpensive, and in some cases, necessary, to compute the
      15$ nelt of sets and tuples as we compute their hashes. as with
      16$ the calculation of hashes, we store the nelt in the set or tuple
      17$ header, but only turn on is_neltok if the form allows.
      18
      19$ the hash code of an object depends only on its value, not its
      20$ representation. in particular the hash code of a map must be
      21$ equivlent to the hash code of a set of pairs.
      22
      23
      24      size gethash(hcsz);     $ hash code returned
      25
      26      size spec(hs);          $ specifier for item to be hashed
      27
      28      size arg(hs);           $ argument to recursive part of routine
      29
      30      size tstart(ps);        $ stack pointer at start of routine
      31
      32      size i(ps);             $ loop index
      33      size j(ps);             $ loop index
      34      size word(hs);          $ data word of long string, etc
      35      size char_hash(hcsz);   $ hash of group of characters
      36      size ss(ssz);           $ string specifier
      37      size len(ps);           $ length of character string
      38      size key(hs);           $ descriptor for packed tuples
      39      size ebb(ps);           $ ls_bit of set
      40      size ebw(ps);           $ ls_word of set
      41      size om_val(hs);        $ untyped om value
      42
      43      size fval(hs);          $ function called
mjsa 122      size hashli(hcsz);      $ computes hash for long integers
      44
      45
      46$ stacked variables
      47
      48 .=zzyorg b $ reset counters for stack offsets
      49
      50      local(retpt);   $ return pointer
      51
      52      local(p);               $ pointer to long value
      53
      54      local(indx);            $ loop index
      55      local(lim);             $ loop limit
      56
      57      local(tuphc);           $ hash code of tuple
      58      local(comphash);        $ component hash
      59      local(n);               $ nelt
      60
      61      local(s);               $ pointer to set
      62      local(sethc);           $ hash code of set
      63      local(e);               $ pointer to current eb
      64      local(x);               $ domain element
      65      local(im);              $ map image
      66      local(hash_x);          $ hash of x
      67      local(hash_im);         $ hash of im
      68
      69
      70 .+st init_time(st_hash);
      71
      72      tstart = t;  $ save initial recursion stack pointer
      73
      74 .=zzyorg a    $ reset counter for return labels
      75
      76      arg = spec;   $ make local copy of specifier
      77
      78
      79/entry/                $ recursive entry point
      80
      81      r_entry;          $ increment recursion stack
      82
      83/switch/       $ branch on type
      84
      85      go to case(otype_ arg) in t_min to t_max;
      86
      87
      88/case(t_int)/           $ short atomic types
      89
      90/case(t_atom)/
      91
      92/case(t_proc)/  $ procedures
      93
      94/case(t_lab)/  $ label
      95
stra 413$ we use the low order bits of the value field. these are accessed
      99$ through the macro 'short_hash'.
     100
     101      gethash = hcsd * short_hash(arg);
     102
     103      go to exit;
     104
     105
stra 414/case(t_string)/              $ short character string
stra 415
stra 416$ the hash code of a short character string is the same as the hash code
stra 417$ for a long character string of the same value.
stra 418
stra 419      len = sc_nchars_ arg;
stra 420      if len = 0 then
stra 421          gethash = 0;
stra 422      else
stra 423          gethash = hcsd * (2 * (scchar(arg, 1)) + 1);
stra 424      end if;
stra 425      go to exit;
     106
     107/case(t_elmt)/          $ element
     108
     109$ if arg is a base element we can get its hash from the base eb.
     110$ otherwise arg points to an element which was hashed when it
     111$ was put into the set. if the element itself is a set or tuple,
     112$ its hash field must still be valid.
     113
     114      p = value_ arg;   $ get pointer into set.
     115
     116      if htype(p) = h_ebb then
     117          gethash = ebhash(p);
     118
     119          go to exit;
     120
     121      else
     122$ dereference arg and see if it is a set or tuple. if so, its hash
     123$ field is still valid.
     124          deref(arg);
     125
     126          if ^ isprim(otype_ arg) then  $ set or tuple
     127              gethash = hash(value_ arg);
     128              go to exit;
     129          end if;
     130
     131          go to switch;   $ recalculate hash
     132      end if;
     133
     134
     135/case(t_latom)/         $ long atom
     136
     137      gethash = hcsd * la_value(value_ arg);
     138
     139      go to exit;
     140
     141
     142/case(t_real)/            $ real
     143
     144$ the hash of a real is the same as that of an integer, namely
     145$ its low order bits. this means the hash of a normalized real
     146$ is usually zero, a very poor idea, but it also means that the
     147$ same code can be used to hash all untyped tuples. since sets of
     148$ reals are almost unheard of anyway, there is no loss.
     149
     150      gethash = hcsd * (.f. 1, hcsz, rval(value_ arg));
     151
     152      go to exit;
     153
     154
     155/case(t_lint)/       $ long integers
     156
mjsa 123      gethash = hashli(arg);
     162
     163      go to exit;
     164
     165
     166/case(t_istring)/
     167
     168      ss  = value_ arg;       $ get string specifier
     169      len = ss_len(ss);       $ and length of string
     170
     171      if len = 0 then
     172          gethash = 0;
     173      else
     174          gethash = icchar(ss, 1) + icchar(ss, ss_len(ss)) + ss_len(ss);
     175          gethash = hcsd * gethash;
     176      end if;
     177      go to exit;
     178
     179
     180
     181/case(t_tuple)/        $ standard tuples
     182
     183$ the hash code of a tuple t is the setl expression
     184$
     185$      hc_tuple + +/[ i *  hash(x) : x = t(i)]
     186$
     187$ where hc_tuple is a constant used to distinguish between the
     188$ hash codes for [1] and <<1>>.
     189
     190
     191      p = value_ arg;  $ get pointer to tuple
     192
     193      if is_hashok(p) then    $ already have hash
     194          gethash = hash(p);
     195          go to exit;
     196      end if;
     197
     198
     199      indx = 1;         $ initialize for loop
     200      lim  = nelt(p);
     201
     202      tuphc = hc_tuple;     $ hash code of tuple
     203
     204      while indx <= lim;
     205          arg = tcomp(p, indx);
     206
     207          if ^ is_om_ arg then
     208              r_call;   $ get hash recursively.
     209              tuphc = tuphc + indx * gethash;$ adjust hash then incremen
     210          end if;
     211
     212          indx = indx + 1;
     213      end while;
     214
     215
     216      set_hash(p, tuphc);
     217
     218      gethash = tuphc;
     219      go to exit;
     220
     221/case(t_stuple)/          $ special tuple
     222
     223$ we use the same function for special tuples. real and integer tuples
     224$ share the same loop.
     225
     226      p = value_ arg;     $ get pointer to tuple
     227
     228      if is_hashok(p) then   $ already have hash
     229          gethash = hash(p);
     230          go to exit;
     231      end if;
     232
     233
     234      go to tc(htype(p)) in h_ptuple to h_rtuple;
     235
     236
     237/tc(h_ptuple)/                $ packed tuple
     238
     239      indx = 1;               $ initialize loop
     240      lim  = nelt(p);
     241
     242      tuphc = hc_tuple;       $ hash code for tuple
     243
     244      key = ptkey(p);
     245
     246      while indx <= lim;
     247
     248          word = pcomp(p, indx);
     249          unpack(key, word, arg);
     250
     251          if ^ is_om_ arg then
     252              r_call;         $ get hash recursively
     253              tuphc = tuphc + indx * gethash;  $ adjust hash
     254          end if;
     255
     256          indx = indx + 1;
     257
     258      end while;
     259
     260      set_hash(p, tuphc);
     261      gethash = tuphc;
     262
     263      go to exit;
     264
     265
     266/tc(h_ituple)/                $ untyped integer tuple
     267
     268/tc(h_rtuple)/                $ untyped real tuple
     269
     270$ iterate over the tuple, computing the hash of each component as if
     271$ it were a real, short int, or long int. in all three cases, this
     272$ means merely taking the low order bits.
     273
     274      gethash = hc_tuple;
     275
     276      om_val = tcomp(p, 0);  $ get om value
     277
     278      do i = 1 to nelt(p);
     279
     280          word = tcomp(p, i);  $ get untyped component
     281          if (word = om_val) cont do i;
     282
     283          gethash = gethash + i * hcsd * (.f. 1, hcsz, word);
     284      end do;
     285
     286      set_hash(p, gethash);
     287
     288      go to exit;
     289
     290
     291/case(t_set)/          $ sets
     292
     293$ the hash code of a set is the sum
     294$
     295$     hc_set + +/[ hash(x) : x in s]
     296$
     297$ since we are iterating through the set anyway, we also update its
     298$ nelt.
     299
     300$ see if the hash of the set is already valid. otherwise initialize
     301$ sethc to the hash of a null set, and n to 0, then jump on the type of
     302$ the set.
     303
     304      s = value_ arg;    $ get pointer to set.
     305
     306      if is_hashok(s) then     $ already have hash
     307          gethash = hash(s);
     308          go to exit;
     309      end if;
     310
     311
     312      sethc = hc_set;  $ hash of set
     313      n = 0;  $ nelt of set.
     314
     315$ jump on type of set
     316
     317      go to sc(htype(s)) in h_uset to h_rset;
     318
     319
     320/sc(h_uset)/      $ unbased set
     321
     322$ iterate over the set, adding the hash of each element. each
     323$ element was hashed when it was put into the set. therefore, if
     324$ the element is itself a set or tuple, its hash field is still
     325$ valid.
     326
     327      next_loop(e, s);
     328
     329          arg = ebspec(e);
     330          n = n+1;  $ nelt of set
     331
     332          if isprim(type_ arg) then  $ recompute hash
     333              r_call;
     334              sethc = sethc + gethash;
     335
     336          else   $ reuse hash in header
     337              sethc = sethc + hash(value_ arg);
     338          end if;
     339
     340      end_next;
     341
     342      go to esac;
     343
     344
     345/sc(h_lset)/     $ local set
     346
     347$ get the hash of each element from the base.
     348
     349      ebb = ls_bit(s);   $ get ls_bit and ls_word of set
     350      ebw = ls_word(s);
     351
     352      next_loop(e, s);    $ iterate over base
     353
     354          if (.f. ebb, 1, heap(e+ebw) = no) cont; $ not in set
     355
     356          sethc = sethc + ebhash(e);
     357          n = n+1;
     358
     359      end_next;
     360
     361      go to esac;
     362
     363
     364/sc(h_rset)/    $ remote set
     365
     366$ this case is very similar to the above, except in the way we test
     367$ membership.
     368
     369      next_loop(e, s);
     370
     371          i = ebindx(e);
     372
     373          if (i > rs_maxi(s))   cont_next;
     374          if (rsbit(s, i) = no) cont_next;
     375
     376          sethc = sethc + ebhash(e);
     377          n = n+1;
     378      end_next;
     379
     380      go to esac;
     381
     382
     383/esac/     $ end of set case
     384
     385      set_hash(s, sethc); $ save nelt and hash
     386      set_nelt(s, n);
     387
     388      gethash = sethc;
     389      go to exit;
     390
     391
     392/case(t_map)/          $ maps
     393
     394$ the hash code of a map is computed as if it were a set of pairs.
     395$ as usual, we begin by checking whether the hash is already
     396$ available.
     397
     398$ since the hash code of a map is hard to compute and rarely
     399$ needed, there is a tempation to merely convert the map to
     400$ a set. however this conversion would require mutual recursion
     401$ of the convert, equality and hash routines.
     402
     403      if is_hashok(value_ arg) then  $ already have hash
     404          gethash = hash(value_ arg);
     405          go to exit;
     406      end if;
     407
     408$ we compute the hash as follows:
     409$
     410$ 1. initialize the hash 'sethc' to hc_set and the nelt 'n' to 0.
     411$
     412$ 2. set 's' to point to the map and iterate for all x in s.
     413$
     414$ 3. if the image of x is single valued, set sethc to
     415$        sethc + hc_tuple + hash(x) + 2 * hash(f(x))
     416$    set n to n+1.
     417$
     418$ 4. otherwise, set sethc to
     419$        sethc + +/[ hc_tuple + hash(x) + 2*hash(y) : y in f<>]
     420$
     421$    we do some factoring of this expression to avoid the iteration
     422$    and come up with:
     423$
     424$        sethc := sethc + # f<> * (hc_tuple + hash(x))
     425$                       + 2 * (hash(f<>) - hc_set);
     426$
     427$    in addition, we set n to n + # f<>.
     428
     429
     430      s = value_ arg;
     431
     432      sethc = hc_set;
     433      n = 0;
     434
     435      next_loop(e, s);
     436
     437          x = ebspec(e);
     438          im = fval(s, e, no);
     439
     440          if (is_om_ im) cont;
     441
     442          arg = x;   $ get hash of x
     443          r_call;
     444
     445          hash_x = gethash;
     446
     447          arg = im;  $ get hash of f(x) or f@x\.
     448          r_call;
     449
     450          hash_im = gethash;
     451
     452          if is_multi_ im then
     453              p = value_ im;
     454              if (nelt(p) = 0) cont;
     455
     456              sethc = sethc + nelt(p) * (hc_tuple + hash_x) +
     457                                    2 * (hash_im - hc_set);
     458
     459              n = n + nelt(p);
     460
     461          else
     462              sethc = sethc + hc_tuple + hash_x + 2 * hash_im;
     463              n     = n + 1;
     464          end if;
     465
     466      end_next;
     467
     468      set_hash(s, sethc);
     469      set_nelt(s, n);
     470
     471      gethash = sethc;
     472
     473      go to exit;
     474
     475case_om;       $ om types
     476
     477      gethash = 0;   $ all nils have a hash of 0.
     478
     479      go to exit;
     480
     481
     482
     483/exit/
     484
     485      gethash = .f. 1, hcsz, gethash;
     486
     487      r_exit;
     488
     489      if t ^= tstart then
     490          go to rlab(retpt) in 1 to zzya;
     491      else
     492 .+st     save_time(st_hash);
     493          return;
     494      end if;
     495
     496
     497
     498$ drop local variables
     499
     500      macdrop8(retpt, p, i, lim, tuphc, n, s, sethc)
     501      macdrop4(e, indx, x, im);
     502      macdrop2(hash_x, hash_im);
     503
     504      end fnct gethash;
       1 .=member getnelt
       2      fnct getnelt(spec);
       3
       4$ this routine handles the setl nelt operator. it returns ? spec
       5$ as a short integer.  sets and tuples are handled by calling
       6$ 'oknelt'.
       7
      11      size getnelt(hs);   $ specifier returned
      12
      13      size spec(hs);    $ specifier for argument
      14
      15      size arg(hs),   $ copy of argument
      16           n(ps),     $ result as untyped integer
      17           ss(ssz);   $ string specifier
      18
      19
      23$ copy spec so that it can be dereferenced, then jump on its type
      24      arg = spec;
      25
      26/switch/     $ jump on type
      27
      28      go to case(otype_ arg) in t_min to t_max;
      29
      30
      31
      33/case(t_int)/          $ short int
      34
      35      go to error;
      36
      37/case(t_string)/        $ short character strings
      38
      39      n = sc_nchars_ arg;
      40      go to esac;
      41
      42/case(t_atom)/     $ error types
      43
      44/case(t_proc)/  $ procedures
      45
      46/case(t_lab)/  $ labels
      47
      48/case(t_latom)/         $ long atom
      49
      50      go to error;
      51
      52/case(t_elmt)/         $ element
      53
      54      deref(arg);
      55      go to switch;
      56
      57
      58/case(t_lint)/         $ long integers
      59
      60      go to error;
      61
      62/case(t_istring)/       $ long chars
      63
      64      ss = value_ arg;
      65      n = ss_len(ss);
      66      go to esac;
      67
      68
      69/case(t_real)/         $ reals
      70
      71      go to error;
      72
      73/case(t_tuple)/         $ tuples and sets
      74
      75/case(t_stuple)/
      76
      77/case(t_set)/
      78
      79/case(t_map)/
      80
      81      ok_nelt(arg);
      82      n = nelt(value_ arg);
      83      go to esac;
      84
      85case_om;            $ om types
      86
      87      call err_om(15);
      88
      89      getnelt = err_val(f_gen);
      90
      91      return;
      92
      93
      94/esac/         $ build specifier and return
      95
      96      build_spec(getnelt, t_int, n);
      97
      98      return;
      99
     100
     101/error/     $ type error
     102
     103      call err_type(32);
     104
     105      getnelt = err_val(f_gen);
     106
     107      return;
     108
     109
     110      end fnct getnelt;
       1 .=member okneltr
       2      subr okneltr(spec);
       3
       4$ this routine updates the nelt of a set or tuple. we assume that
       5$ its nelt field is invalid on entry to the routine. on exit the
       6$ nelt field is valid. in addition, the objects is_neltok bit has
       7$ been turned on if its form allows it.
       8
       9$ the routine consists of an inner recursive section which determines
      10$ the objects nelt and a section which stores it in the set/map header.
      11$ the nelt is always placed in the variable -n- then stored in the
      12$ header.
      13
      14
      15$ variable declarations
      16
      17      size spec(hs);   $ specifier for set or tuple
      18
      19      size arg(hs);  $ local copy of argument
      20
      21      size tstart(ps);   $ recursion stack pointer at start of routine
      22
      23      size j(ps),      $ loop index
      24           im(hs),   $ map image
      25           om_val(hs); $ untyped om
      26
      27
      28      size fval(hs);  $ function called
      29
      30$ stacked variables
      31
      32 .=zzyorg b $ reset counters for stack offsets
      33
      34      local(retpt);  $ return pointer
      35
      36      local(e);    $ pointer to current eb
      37      local(im);  $ specifier for its image
      38      local(n);     $ nelt being calculated
      39      local(p);      $ pointer to set or tuple
      40      local(bit);     $ ls_bit of local object
      41      local(word);      $ ls_word of local object
      42
      43
      44
      45
      46/begin/               $ begin execution
      47
      48 .+st init_time(st_nelt);
      49      tstart = t;  $ save initial recursion stack pointer
      50
      51 .=zzyorg a    $ reset counter for return labels
      52
      53      arg = spec;       $ make local copy of argument
      54
      55
      56/entry/           $ recursive entry point
      57
      58      r_entry;  $ increment recursion stack
      59
      60      p = value_ arg;     $ get pointer to set or tuple
      61
      62      go to case(htype(p)) in h_tuple to h_lrmap;
      63
      64
      65/case(h_tuple)/            $ standard tuple
      66
      67$ assume nelt is equal to maxindx, and then work towards the start of
      68$ the tuple, looking for the first defined element.
      69      n = maxindx(p);
      70
      71      while n > 0 & is_om_ tcomp(p, n);
      72          n = n-1;
      73      end while;
      74
      75      go to done;
      76
      77
      78/case(h_ituple)/         $ untyped integer tuple
      79
      80/case(h_rtuple)/              $ untyped real tuple
      81
      82$ we use a loop similar to the above, comparing elements with the
      83$ appropriate om value
      84
      85      om_val = tcomp(p, 0);  $ get om value
      86
      87      n = maxindx(p);
      88
      89      while n > 0 & tcomp(p, n) = om_val;
      90          n = n-1;
      91      end while;
      92
      93      go to done;
      94
      95
      96/case(h_ptuple)/         $ packed tuples
      97
      98      n = maxindx(p);      $ use alloc for first assumption
      99
     100      while n > 0 & pcomp(p, n) = 0;   $ this loop can be faster
     101          n = n-1;
     102      end while;
     103
     104      go to done;
     105
     106
     107/case(h_uset)/          $ unbased set.
     108
     109$ the nelt of an unbased set is the neb of its hash table
     110      n = neb(hashtb(p));
     111      go to done;
     112
     113
     114/case(h_rset)/              $ remote based set
     115
     116$ the nelt of a remote set is the nelt of its bit string.
     117
     118      n = 0;
     119
     120      do j = 1 to rswords(p);
     121          n = n + .nb. rsword(p, j);
     122      end do;
     123
     124      go to done;
     125
     126
     127/case(h_lset)/          $ local based set
     128$ the nelt of a local set is the number of membership bits on for it
     129$ in its base.
     130
     131      bit = ls_bit(p);   $ get bit and word position in base.
     132      word = ls_word(p);
     133
     134      n = 0;
     135
     136      next_loop(e, p);    $ iterate over base
     137
     138          n = n + .f. bit, 1, heap(e+word);
     139
     140      end_next;
     141
     142      go to done;
     143
     144
     145
     146/case(h_umap)/                $ maps
     147
     148/case(h_lmap)/
     149
     150/case(h_rmap)/
     151
     152/case(h_limap)/
     153
     154/case(h_lrmap)/
     155
     156/case(h_lpmap)/
     157
     158/case(h_rimap)/
     159
     160/case(h_rrmap)/
     161
     162/case(h_rpmap)/
     163
     164
     165$ calculating the nelt of a map is a recursive procedure involving
     166$ a nelt calculation on all its range sets. our procedure has
     167$ four steps:
     168
     169$ 1. set n to 0.
     170$ 2. iterate for all x _ f, and set im = fval(f, x).
     171$ 3. if im has its is_multi bit set, add in the nelt of the range set
     172$ 4. otherwise add 1 if im is not om.
     173
     174      n = 0;
     175
     176      next_loop(e, p);     $ iterate over domain.
     177
     178          im = fval(p, e, no);     $ get image
     179
     180          if is_multi_ im then  $ add in nelt of range set.
     181              if ^ is_neltok(value_ im) then  $ update nelt of range set
     182                  arg = im;
     183                  r_call;
     184              end if;
     185
     186              n = n+nelt(value_ im);
     187
     188          else         $ singlevalued
     189              if (^ is_om_ im) n = n+1;
     190          end if;
     191
     192      end_next;
     193
     194      go to done;
     195
     196
     197/done/          $ store nelt in header
     198
     199      set_nelt(p, n);
     200
     201
     202/exit/        $ recursive exit point
     203      r_exit;
     204
     205      if t ^= tstart then     $ recursive return
     206          go to rlab(retpt) in 1 to zzya;
     207      else
     208 .+st     save_time(st_nelt);
     209          return;
     210      end if;
     211
     212
     213
     214$ drop local variables
     215
     216      macdrop4(retpt, n, p, bit)
     217      macdrop2(word, im);
     218      macdrop(e)
     219
     220      end subr okneltr;
       1 .=member nullp
       2      fnct nullp(set);
       3
       4$ this predicate tests a set to see if it is null.
       5$ if the set is null, we set its nelt to 0. we also set its
       6$ is_neltok flag if the form allows.
       7
       8$ variable declarations
       9
      10      size nullp(1);    $ boolean value returned
      11
      12      size set(ps);   $ pointer to set
      13
      14      size tstart(ps); $ pointer to recursion stack at start of routine
      15
      16      size s(ps);   $ parameter to recursive routine
      17
      18      size j(ps),    $ loop index
      19           im(hs);     $ map image
      20
      21
      22      size fval(hs);  $ function called
      23
      24$ stacked variables
      25
      26 .=zzyorg b $ reset counters for stack offsets
      27
      28      local(retpt);    $ return pointer
      29
      30      local(bit);     $ ls_bit of local set
      31      local(word);     $ ls_word of local set or map
      32
      33      local(e);     $ pointer to current eb
      34      local(map);       $ pointer to map being tested
      35
      36
      37
      38$ begin execution
      39
      40      tstart = t;  $ save initial recursion stack pointer.
      41
      42 .=zzyorg a    $ reset counter for return labels
      43
      44      s = set;    $ local copy of argument
      45
      46      if is_neltok(s) then  $ nelt valid on top level
      47          nullp = (nelt(s) = 0);
      48          return;
      49      end if;
      50
      51
      52/entry/           $ recursive entry point
      53
      54      $ nb. heap_valid = no during garbage collections.
      55      $ nb. this routine has five local variables, about to be pushed
      56      $     onto the stack.
      57 .+gt if (^ heap_valid & (t - h - 5) < min_gap) call err_fatal(50);
      58
      59      r_entry;  $ increment recursion stack
      60
      61      if (neb(hashtb(s)) = 0) go to pass;  $ hash table empty
      62
      63$ jump on type
      64      go to case(htype(s)) in h_uset to h_lrmap;
      65
      66
      67/case(h_uset)/                $ unbased set
      68
      69/case(h_umap)/                $ unbased map
      70
      71      go to fail;  $ since hash table is non empty.
      72
      73
      74/case(h_rset)/                $ remote set
      75
      76      $ see if any bits of bitstring are on.
      77      do j = 1 to rswords(s);
      78          if (rsword(s, j) ^= 0) go to fail;
      79      end do;
      80
      81      go to pass;
      82
      83
      84/case(h_lset)/                $ local set
      85
      86      bit  = ls_bit(s);       $ get bit and word position in base.
      87      word = ls_word(s);
      88
      89      next_loop(e, s);        $ iterate over base
      90          if (.f. bit, 1, heap(e+word) ^= 0) go to fail;
      91      end_next;
      92
      93      go to pass;
      94
      95
      96/case(h_lmap)/                $ local map
      97
      98/case(h_rmap)/                $ remote map
      99
     100/case(h_lpmap)/               $ local packed map
     101
     102/case(h_rpmap)/               $ remote packed map
     103
     104
     105$ iterate over the domain. if this is an mmap, see whether all
     106$ images are null. otherwise see if they are all om.
     107
     108      map = s;  $ save pointer to map
     109
     110      next_loop(e, map);     $ iterate over domain.
     111
     112          im = fval(map, e, no);     $ get image
     113
     114          if is_mmap(map) then
     115              s = value_ im;
     116
     117              if is_neltok(s) then
     118                  if (nelt(s) ^= 0) go to fail;
     119              else
     120                  r_call;
     121                  if (^ nullp) go to fail;
     122              end if;
     123
     124          else         $ single valued
     125              if (^ is_om_ im) go to fail;
     126
     127          end if;
     128      end_next;
     129
     130      s = map;  $ restore parameter
     131
     132      go to pass;
     133
     134
     135/case(h_limap)/               $ local integer map
     136
     137      word = ls_word(s);
     138
     139      next_loop(e, s);
     140          if (heap(e + word) = om_int) go to fail;
     141      end_next;
     142
     143      go to pass;
     144
     145
     146/case(h_lrmap)/               $ local real map
     147
     148      word = ls_word(s);
     149
     150      next_loop(e, s);
     151          if (heap(e + word) = om_real) go to fail;
     152      end_next;
     153
     154      go to pass;
     155
     156
     157/case(h_rimap)/               $ remote integer map
     158
     159      next_loop(e, s);
     160          if (ebindx(e) > maxindx(s+hl_rmap)) go to fail;
     161          if (tcomp(s+hl_rmap, ebindx(e)) = om_int) go to fail;
     162      end_next;
     163
     164      go to pass;
     165
     166
     167/case(h_rrmap)/               $ remote real map
     168
     169      next_loop(e, s);
     170          if (ebindx(e) > maxindx(s+hl_rmap)) go to fail;
     171          if (tcomp(s+hl_rmap, ebindx(e)) = om_int) go to fail;
     172      end_next;
     173
     174      go to pass;
     175
     176
     177/pass/       $ return true
     178
     179$ as long as we know s-s nelt is zero, we set its nelt and is_neltok
     180$ fields before returning.
     181      set_nelt(s, 0);
     182
     183      nullp = yes;
     184      go to exit;
     185
     186
     187/fail/       $ return false
     188
     189      nullp = no;
     190
     191
     192/exit/        $ recursive exit point
     193
     194      r_exit; $ pop recursion stack
     195
     196      if t ^= tstart then     $ recursive return
     197          go to rlab(retpt) in 1 to zzya;
     198      else
     199          return;
     200      end if;
     201
     202
     203
     204$ drop local variables
     205
     206      macdrop4(retpt, bit, word, e);
     207      macdrop(map);
     208
     209
     210      end fnct nullp;
       1 .=member arb
       2      fnct arb(arg);
       3
       4$ this is the general setl arb routine.  it is called when the mode
       5$ of the argument is not known at compile time.   it calls the arbs
       6$ routine for sets and maps, the only modes for which arb is defined.
       7
       8
       9      size arg(hs);           $ specifier for set or map
      10      size arb(hs);           $ specifier returned
      11      size a(hs);             $ local copy of argument
      12      size arbs(hs);          $ routine to compute arb(set_mode)
      13
      14
      15      a = arg;   deref(a);
      16
      17      if ^ isset(otype_ a) then   $ error conditions
      18          if is_om_ a then
      19              call err_om(16);
      20          else
      21              call err_type(33);
      22          end if;
      23
      24          if isprim(type_ a) then
      25              arb = err_val(f_gen);
      26          else
      27              arb = err_val(hform(value_ a));
      28          end if;
      29
      30      else
      31          arb = arbs(a);
      32      end if;
      33
      34
      35      end fnct arb;
       1 .=member arbs
       2      fnct arbs(set);
       3
       4$ this routine performs the 'arb' function on sets and maps.
       5
       6
       7$ variable declarations
       8
       9      size arbs(hs);     $ specifier returned
      10
      11      size set(hs);   $ specifier for set
      12
      13      size tstart(ps);  $ recursion stack pointer at start of routine
      14
      15      size s(ps);   $ pointer to set, used as argument to recursive
      16                    $ part of routine.
      17
      18
      19      size e(ps),   $ pointer to eb
      20           p(ps);  $ pointer to pair
      21
      22      size bit(ps),  $ ls_bit of set
      23           word(ps), $ ls_word of set
      24           indx(ps);  $ ebindx of element
      25
      26      size nullp(1),   $ functions called
      27           fval(hs);
      28
      29$ stacked variables
      30
      31 .=zzyorg b $ reset counters for stack offsets
      32
      33      local(retpt);     $ return pointer
      34
      35      local(map);      $ pointer to map
      36
      37      local(dom);  $ domain specifier
      38      local(im);   $ image specifier
      39
      40      local(ended);     $ flags end of hash table
      41
      42
      43
      44/begin/             $ begin execution
      45
      46      tstart = t;         $ save initial recursion stack pointer
      47
      48 .=zzyorg a    $ reset counter for return labels
      49
      50      s = value_ set; $ get pointer to set
      51
      52/entry/          $ recursive entry point
      53
      54      r_entry;  $ increment recursion stack
      55
      56      if (^ is_map(s)) go to case_set;   $ branch for sets
      57
      58
      59/case_map/                $ map cases
      60
      61      map = s;          $ save pointer to map we are iterating over
      62
      63
      64$ find domain element
      65
      66$ we begin by finding the first domain element whose image is
      67$ defined. for mmaps, we must skip domain elements whose images
      68$ are null range sets.
      69
      70      next_loop(e, map);    $ iterate over domain
      71
      72          im = fval(map, e, yes);      $ get image
      73
      74          if is_mmap(map) then  $ look for non-null image
      75              p = value_ im;   $ get pointer to range set
      76
      77              if is_neltok(p) then
      78                  if (nelt(p) ^= 0) quit;
      79              else
      80                  if (^ nullp(p)) quit;
      81              end if;
      82
      83          else  $ look for defined image
      84              if (^ is_om_ im) quit;
      85          end if;
      86
      87      end_next;
      88
      89$ build specifier for domain element
      90
      91      if is_based(map) then  $ value is element of base
      92          build_spec(dom, t_elmt, e);
      93
      94      else           $ value is actual specifier in set
      95          is_shared_ ebspec(e) = yes;
      96          dom = ebspec(e);
      97      end if;
      98$
      99$ special case: null map
     100$
     101      if is_ebtemp(e) then
     102          is_om_ dom = yes;
     103          im = fval(map, e, yes);
     104          ended = yes;
     105      else
     106          ended = no;
     107      end if;
     108
     109$ do arb on range set if necessary
     110
     111      if is_multi_ im then     $ get arbitrary element of range set
     112          s = value_ im;
     113          r_call;
     114
     115          im = arbs;
     116      end if;
     117
     118$ build pair .
     119
     120      get_pair(p);
     121
     122      hform(p) = ft_elmt(hform(map)); $ get form and base array from map
     123
     124      tcomp(p, 1) = dom;  $ set components
     125      tcomp(p, 2) = im;
     126
     127      build_spec(arbs, t_tuple, p);    $ build specifier
     128      if (ended = yes) is_om_ arbs = yes; $ flag omega result
     129
     130      go to exit;
     131
     132
     133
     134
     135/case_set/             $ set cases
     136
     137$ special case null sets
     138
     139      if is_neltok(s) & nelt(s) = 0 then  $ null set
     140
     141          if is_based(s) then  $ return base element
     142              build_spec(arbs, t_oelmt, template(s));
     143          else    $ return value
     144              arbs = ebspec(template(s));
     145          end if;
     146
     147          go to exit;
     148      end if;
     149
     150                          $ jump on type
     151
     152      go to sc(htype(s)) in h_uset to h_rset;
     153
     154
     155/sc(h_uset)/       $ unbased set
     156
     157$ look for the first element which is not a dummy hash header. we
     158$ do this with a next_loop which quits the first time we enter
     159$ the body of the loop.
     160
     161      next_loop(e, s);
     162
     163          quit;
     164
     165      end_next;
     166
     167$ value is actual specifier in set. we assume that the eb specifier for
     168$ the template has its is_om bit already set, so there is no need to
     169$ test whether the set is empty.
     170$
     171      is_shared_ ebspec(e) = yes;
     172      arbs = ebspec(e);
     173
     174      go to exit;
     175
     176
     177
     178/sc(h_lset)/         $ local based set
     179
     180$ find arb element of base with membership bit on.
     181
     182      bit = ls_bit(s);   $ get bit and word offset
     183      word = ls_word(s);
     184
     185
     186      next_loop(e, s);     $ iterate over base
     187
     188          if (.f. bit, 1, heap(e+word)) quit;  $ in set
     189
     190      end_next;
     191
     192
     193      build_spec(arbs, t_elmt, e);  $ value is element of base
     194      if (is_ebtemp(e)) is_om_ arbs = yes;  $ flag end of set
     195
     196      go to exit;
     197
     198
     199
     200/sc(h_rset)/          $ remote based set
     201
     202$ advance in base looking for arb element with membership bit on.
     203
     204      next_loop(e, s);   $ iterate over base
     205
     206          indx = ebindx(e);    $ get base index
     207
     208          if (indx > rs_maxi(s)) cont;
     209
     210          if (rsbit(s, indx)) quit;
     211
     212      end_next;
     213
     214
     215      build_spec(arbs, t_elmt, e);  $ value is element of base
     216      if (is_ebtemp(e)) is_om_ arbs = yes;  $ flag end of set
     217
     218      go to exit;
     219
     220
     221
     222/exit/             $ recursive exit
     223
     224      r_exit;
     225
     226      if t ^= tstart then     $ recursive return
     227          go to rlab(retpt) in 1 to zzya;
     228
     229      else
     230          return;
     231      end if;
     232
     233
     234
     235$ drop local variables
     236
     237      macdrop4(retpt, map, dom, im)
     238      macdrop(ended)
     239
     240      end fnct arbs;
       1 .=member arb1
       2
       3      fnct arb1(im);
       4
       5$ this routine  is used to convert a map image from mmap form to map
       6$ form. im is a specifier for a map image with its is_multi flag set.
       7$ if im represents a null or singleton set, we perform -arb- on it.
       8$ otherwise we return it unchanged.
       9
      10
      11      size arb1(hs);    $ specifier returned
      12
      13      size im(hs);      $ specifier for image
      14
      15      size arbs(hs);  $ function called
      16
      17
      18      ok_nelt(im);     $ update its nelt.
      19
      20      if nelt(value_ im) <= 1 then  $ get element
      21          arb1 = arbs(im);
      22      else   $ return im
      23          arb1 = im;
      24      end if;
      25
      26
      27      end fnct arb1;
       1 .=member dom
       2      fnct dom(arg, fm);
       3
       4$ this routine calculates the domain of a set or map. there are
       5$ three possible cases:
       6
       7$ 1. arg is a set. convert it to a map and proceed as in case(3).
       8
       9$ 2. arg is a based map. iterate over the base, finding all
      10$    base elements which are in the domain of the map and
      11$    put them into the result.
      12
      13$ 3. arg is an unbased map. build a nullset with the same number
      14$    of hash headers as the map, then iterate over each clash list
      15$    of the map, putting domain elements onto the corresponding
      16$    clash list of the result.
      17
      18
      19      size arg(hs);  $ specifier for set or map
      20      size fm(ps);            $ form of result
      21
      22      size dom(hs);  $ specifier returned
      23
      24      size map(hs),   $ specifier for map
      25           m(ps),    $ pointer to map
      26           mmap_flag(1),      $ true for m-maps
      27           conv_flag(1),      $ true if element conversion required
      28           based_flag(1),     $ true if result is based subset
      29           s(ps),     $ pointer to set being build
      30           logn(ps),  $ lognhedrs of map
      31           n(ps),  $ estimate of nelt of result
      32           count(ps),  $ actual nelt of result
      33           eb(ps),     $ pointer to current eb of map
      34           im(hs),     $ image
      35           p(ps),      $ pointer to range set
      36           spec(hs);   $ specifier for domain element
      37      size xfm(ps);           $ element form of result
      38
      39      size nullset(hs),   $ builds null set
      40           nullp(1),      $ tests for null set
      41           setform(hs),   $ set former
      42           convert(hs),
      43           convsm(hs),    $ converts set to map
      44           fval(hs);  $ returns functional value
      45
      46
      47      map = arg;
      48      deref(map);
      49
      50      if (otype_ map = t_set) map = convsm(map, f_umap);
      51
      52      if otype_ map ^= t_map then
      53          if is_om_ map then
      54              call err_om(30);
      55          else
      56              call err_type(34);
      57          end if;
      58
      59          dom = err_val(fm);
      60          return;
      61      end if;
      62
      63$ split up the based and unbased cases.
      64
      65      m = value_ map;
      66
      67      if ft_elmt(fm) ^= ft_dom(hform(m)) then
      68          conv_flag = yes;   xfm = ft_elmt(fm);
      69      else
      70          conv_flag = no;
      71      end if;
      72
      73      if (htype(m) = h_umap) go to unbased;
      74
      75/based/      $ based case
      76
      77      count = 0;   mmap_flag = is_mmap(m);
      78
      79      next_loop(eb, m);
      80          im = fval(m, eb, no);
      81
      82          if mmap_flag then
      83              p = value_ im;
      84
      85              if is_neltok(p) then
      86                  if (nelt(p) = 0) cont;
      87              else
      88                  if (nullp(p)) cont;
      89              end if;
      90
      91          else
      92              if (is_om_ im) cont;
      93          end if;
      94
      95          build_spec(spec, t_elmt, eb);
      96          if (conv_flag) spec = convert(spec, xfm);
      97          push1(spec);
      98
      99          count = count + 1;
     100      end_next;
     101
     102      dom = setform(fm, count);
     103
     104      return;
     105
     106
     107/unbased/    $ unbased case
     108
     109$ allocate a null set with the same number of headers as
     110$ the map.
     111
     112      logn = lognhedrs(hashtb(m));
     113      n    = pow2(logn);
     114
     115      dom = nullset(fm, n);
     116      s   = value_ dom;
     117
     118      based_flag = is_based(s);
     119
     120$ iterate over map, inserting elements in set
     121
     122      count = 0;   $ nelt of domain
     123
     124      next_loop(eb, m);
     125          spec = ebspec(eb);
     126          if (conv_flag) spec = convert(spec, xfm);
     127
     128          call locate(p, spec, s, yes);
     129          if (based_flag) call sfval(s, p, yes);   $ set subset bit
     130
     131          count = count + 1;
     132      end_next;
     133
     134      set_nelt(s, count);  $ set nelt and hash.
     135      is_hashok(s) = no;
     136
     137      return;
     138
     139      end fnct dom;
       1 .=member range
       2      fnct range(arg, fm);
       3
       4$ this routine finds the range of a set or map. as with the
       5$ domain function, we handle sets by converting a temporary
       6$ copy of the set to a map.
       7
       8$ our algorithm is as follows:
       9
      10$ 1. iterate for all x _ domain map
      11
      12$ 2. get the set im to the image of x.
      13
      14$ 3. if im is multi valued, set the result to result + im;
      15$    otherwise set result = result with im.
      16
      17
      18      size arg(hs);   $ specifier for set or map
      19      size fm(ps);            $ form of result
      20
      21      size range(hs);  $ specifier returned
      22
      23      size map(hs),   $ specifier for map
      24           m(ps),     $ pointer to map
      25           x(ps),     $ pointer to domain
      26           im(hs),    $ specifier for image
      27           s(ps);     $ pointer to result set
      28      size sfm(ps);           $ intermediate set form
      29      size xfm(ps);           $ set element form
      30      size conv_flag(1);      $ true if element conversion required
      31
      32      size fval(hs),  $ functions called
      33           withs(hs),
      34           union(hs),
      35           convert(hs),
      36           convsm(hs),
      37           nullset(hs);
      38
      39
      40$ convert to map if necessary
      41
      42      map = arg;
      43      deref(map);
      44
      45      if (otype_ map = t_set) map = convsm(map, f_umap);
      46
      47      if otype_ map ^= t_map then
      48          if is_om_ map then
      49              call err_om(31);
      50          else
      51              call err_type(35);
      52          end if;
      53
      54          range = err_val(fm);
      55          return;
      56      end if;
      57
      58      m = value_ map;
      59
      60      if ft_type(fm) = f_lset & ^ is_smap(m) then
      61          sfm = f_uset;
      62      else
      63          sfm = fm;
      64      end if;
      65
      66      if ft_elmt(sfm) ^= ft_im(hform(m)) then
      67          conv_flag = yes;   xfm = ft_elmt(sfm);
      68      else
      69          conv_flag = no;
      70      end if;
      71
      72$ allocate null set with same nelt as map
      73      ok_nelt(map);
      74      range = nullset(sfm, nelt(m));
      75
      76$ iterate over map, inserting range elements in set.
      77
      78      next_loop(x, m);
      79          im = fval(m, x, yes);
      80
      81          if is_multi_ im then
      82              if (hform(value_ im) ^= sfm) im = convert(im, sfm);
      83              range = union(range, im, yes);
      84
      85          elseif ^ is_om_ im then
      86              if (conv_flag) im = convert(im, xfm);
      87              range = withs(range, im, yes);
      88          end if;
      89
      90      end_next;
      91
      92      if (fm ^= sfm) range = convert(range, fm);
      93
      94
      95      end fnct range;
       1 .=member subst
       2      fnct subst(arg1, arg2, arg3);
       3
       4$ this is the top level routine for substring extraction.  it
       5$ returns -arg1(arg2 ... arg3)-.  most of the work is done by
       6$ lower level routines.
       7
       8
       9      size arg1(hs),          $ specifier for string or tuple
      10           arg2(hs),          $ specifier for first component
      11           arg3(hs);          $ specifier for last component
      12
      13      size subst(hs);         $ specifier returned
      14
      15      size a1(hs),            $ copies of arguments
      16           a2(hs),
      17           a3(hs);
      18
      19      size first(ps),         $ first component of substring
      20           last(ps),          $ last component of substring
      21           j(ps);             $ loop index
      22
      23      size substt(hs),        $ functions called
      24           substs(hs);
      25
      26
      27      a1 = arg1;              $ copy arguments
      28      a2 = arg2;
      29      a3 = arg3;
      30
      31      deref(a2);
      32      deref(a3);
      33
      34$ check types of bounds
      35
      36      if otype_ a2 ^= t_int then
      37          call err_type(37);
      38          go to error;
      39      end if;
      40
      41      if otype_ a3 ^= t_int then
      42          call err_type(38);
      43          go to error;
      44      end if;
      45
      46$ check range of lower bound: 1 <= a2 <= a3+1
      47
      48      if eq(a2, zero) then
      49          call err_misc(35);
      50          go to error;
      51      end if;
      52
      53      if ivalue_ a2 > (ivalue_ a3)+1 then
      54          call err_misc(36);
      55          go to error;
      56      end if;
      57
      58/switch/
      59
      60      go to case(otype_ a1) in t_min to t_max;
      61
      62
      63/case(t_int)/                 $ short integer
      64
      65      go to error1;
      66
      67
      68/case(t_string)/              $ short character string
      69
      74
      75      first = ivalue_ a2;
      76      last  = ivalue_ a3;
      77
      78      if last > sc_nchars_ a1 then
      79          call err_misc(37);
      80          go to error;
      81      end if;
      82
strb 153      if last = first then  $ must be s(1..1)
strb 154          subst = a1;
strb 155      else    $ s(1..0) or s(2..1)
strb 156          build_spec(subst, t_string, 0);
strb 157      end if;
      89
      90      return;
      91
      92
      93/case(t_atom)/                $ short atom
      94
      95/case(t_proc)/
      96
      97/case(t_lab)/
      98
      99/case(t_latom)/               $ long atom
     100
     101      go to error1;
     102
     103
     104/case(t_elmt)/                $ compressed element
     105
     106      deref(a1);
     107      go to switch;
     108
     109
     110/case(t_lint)/                $ long integer
     111
     112      go to error1;
     113
     114
     115/case(t_istring)/             $ long character string
     116
     117      subst = substs(a1, a2, a3);
     118      return;
     119
     120
     121/case(t_real)/                $ real
     122
     123      go to error1;
     124
     125
     126/case(t_tuple)/               $ standard tuple
     127
     128/case(t_stuple)/              $ packed or untyped tuple
     129
     130      subst = substt(a1, a2, a3);
     131      return;
     132
     133
     134/case(t_set)/                 $ set
     135
     136/case(t_map)/                 $ map
     137
     138      go to error1;
     139
     140
     141case_om;                      $ om type
     142
     143      call err_om(17);
     144
     145/error/                       $ return proper error value
     146
     147      if isprim(type_ a1) then
     148          subst = err_val(f_gen);
     149      else
     150          subst = err_val(hform(value_ a1));
     151      end if;
     152
     153      return;
     154
     155/error1/                      $ illegal type for -a1-
     156
     157      call err_type(36);
     158
     159      subst = err_val(f_gen);
     160
     161      return;
     162
     163
     164      end fnct subst;
       1 .=member substt
       2      fnct substt(a1, a2, a3);
       3
       4$ this routine returns -a(a2...a3)- for tuples.  it does not use
       5$ any of its arguments destructively.
       6
       7$ n.b. -a1- is a specifier for a tuple
       8$      -a2- and -a3- are specifiers for short integers
       9$      1 <= a2 <= a3+1
      10
      11
      12      size a1(hs),            $ specifier for tuple
      13           a2(hs),            $ specifier for first component
      14           a3(hs);            $ specifier for last component
      15
      16      size substt(hs);        $ specifier for result
      17
      18      size oldp(ps),          $ pointer to original tuple
      19           newp(ps);          $ pointer to new tuple
      20
      21      size first(ps),         $ first component
      22           last(ps),          $ last component
      23           len(ps),           $ expected length of new tuple
      24           card(ps);          $ actual length of new tuple
      25
      26      size om_val(hs);        $ omega value
      27
      28      size j(ps);             $ loop index
      29
      30      size nulltup(hs);       $ builds null tuple
      31
      32
      33      oldp  = value_ a1;      $ get values of arguments
      34      first = ivalue_ a2;
      35      last  = ivalue_ a3;
      36
      37$ if we have:
      38
      39$     t := [1, 2, 3, 4];
      40$     s := t(3 ... 6);
      41
      42$ then we will return the tuple [3, 4] with a lot of nils at the
      43$ end of it.  this means that the length of the result is really
      44$ the minimum of a3 and the length of a1(a2 ...).
      45
      46      if (last > nelt(oldp)) last = nelt(oldp);
      47
      48      len = last + 1 - first;
      49
      50$ if we have:
      51
      52$     t := [1, om, om, 4];
      53$     s := t(1 ... 3);
      54
      55$ then we shall return the tuple [1], since we don-t save omegas at
      56$ the end of the tuple.  the variable -card- saves the index of the
      57$ last non-omega value of the new tuple.
      58
      59      card = 0;               $ actual length of tuple
      60
      61      substt = nulltup(hform(oldp), len);
      62      newp   = value_ substt;
      63
      64$ copy components
      65
      66      go to case(htype(newp)) in h_tuple to h_rtuple;
      67
      68
      69/case(h_tuple)/               $ standard tuple
      70
      71$ copy components and set share bits
      72
      73      do j = 1 to len;
      74          is_shared_ tcomp(oldp, (first-1) + j) = yes;
      75          tcomp(newp, j) = tcomp(oldp, (first-1) + j);
      76          if (^ is_om_ tcomp(newp, j)) card = j;
      77      end do;
      78
      79      go to esac;
      80
      81
      82/case(h_ptuple)/              $ packed tuple
      83
      84      om_val = pcomp(oldp, 0);
      85
      86      do j = 1 to len;
      87          pcomp(newp, j) = pcomp(oldp, (first-1) + j);
      88          if (pcomp(newp, j) ^= om_val) card = j;
      89      end do;
      90
      91      go to esac;
      92
      93
      94/case(h_ituple)/              $ untyped tuples
      95
      96/case(h_rtuple)/
      97
      98      om_val = tcomp(oldp, 0);
      99
     100      do j = 1 to len;
     101          tcomp(newp, j) = tcomp(oldp, (first-1) + j);
     102          if (tcomp(newp, j) ^= om_val) card = j;
     103      end do;
     104
     105      go to esac;
     106
     107
     108/esac/                        $ build result specifier and return
     109
     110      set_nelt(newp, card);
     111
     112      build_spec(substt, type_ a1, newp);
     113
     114
     115      end fnct substt;
       1 .=member substs
       2      fnct substs(a1, a2, a3);
       3
       4$ this routine returns -a1(a2...a3)- on indirect strings.
       5
       6$ n.b. -a1- is a specifier for an indirect string
       7$      -a2- and -a3- are specifiers for short integers
       8$      1 <= a2 <= a3+1
       9
      10
      11      size a1(hs),            $ specifier for string
      12           a2(hs),            $ specifier for first component
      13           a3(hs);            $ specifier for last component
      14
      15      size substs(hs);        $ specifier returned
      16
      17      size ss1(ssz),          $ string specifier for a1
      18           ss(ssz),           $ specifier for result
      19           first(ps),         $ position of first component
      20           last(ps),          $ position of last component
      21           len(ps);           $ length
      22
      23
      24      ss1   = value_ a1;      $ get values of arguments
      25      first = ivalue_ a2;
      26      last  = ivalue_ a3;
      27
      28$ check range of upper bound: a3 <= ?a1
      29
      30      if last > ss_len(ss1) then
      31          call err_misc(38);
      32          substs = err_val(f_gen);
      33          return;
      34      end if;
      35
      36      len = last + 1 - first; $ get length of substring
      37
strb 158      if len <= sc_max then  $ result is short string
stra 434          if len = 0 then  $ result is null string
stra 435              build_spec(substs, t_string, 0);
stra 436          else    $ result is single character
stra 437              substs = spec_char;  $ one-character template
stra 438              scchar(substs, 1) = icchar(ss1, first);
stra 439          end if;
stra 440      else
stra 441          build_ss(ss, ss_ptr(ss1), ss_ofs(ss1) + first - 1, len);
stra 442          build_spec(substs, t_istring, ss);
stra 443      end if;
stra 444
      43
      44      end fnct substs;
       1 .=member ssubst
       2      fnct ssubst(arg1, arg2, arg3, arg4);
       3
       4$ this is the top level routine for substring assingments.  it
       5$ returns -arg1(arg2 ... arg3) := arg4-.  most of the work is
       6$ done by lower level routines.
       7
       8
       9      size arg1(hs),          $ specifiers for arguments
      10           arg2(hs),
      11           arg3(hs),
      12           arg4(hs);
      13
      14      size ssubst(hs);        $ specifier returned
      15
      16      size a1(hs),            $ copies of arguments
      17           a2(hs),
      18           a3(hs),
      19           a4(hs);
      20
      21      size j(ps),             $ loop index
      22           first(ps),         $ first component
      23           last(ps);
stra 445      size len1(ps);          $ length of -a1-
stra 446      size len4(ps);          $ length of -a4-
stra 447      size len(ps);           $ length of result
stra 448      size ss(ssz);           $ string specifier
      24
      25      size ssbsts(hs);        $ ssubst on strings
      26      size ssbstt(hs);        $ ssubst on tuples
      27      size convert(hs);       $ conversion utility
      28      size copy1(hs);         $ copy utility
stra 449      size nulllc(ssz);       $ allocates null string
      29
      30
      31      a1 = arg1;              $ copy arguments
      32      a2 = arg2;   deref(a2);
      33      a3 = arg3;   deref(a3);
      34      a4 = arg4;
      35
      36$ check types of bounds
      37
      38      if otype_ a2 ^= t_int then
      39          call err_type(55);
      40          go to error;
      41      end if;
      42
      43      if otype_ a3 ^= t_int then
      44          call err_type(56);
      45          go to error;
      46      end if;
      47
      48$ check range of lower bound: 1 <= a2 <= a3+1
      49
      50      if eq(a2, zero) then
      51          call err_misc(39);
      52          go to error;
      53      end if;
      54
      55      if ivalue_ a2 > (ivalue_ a3)+1 then
      56          call err_misc(40);
      57          go to error;
      58      end if;
      59
      60/switch/
      61
      62      go to case(otype_ a1) in t_min to t_max;
      63
      64
      65/case(t_int)/                 $ short integer
      66
      67      go to error1;
      68
      69
      70/case(t_string)/              $ short character strings
      71
stra 450      if (otype_ a4 ^= t_string & otype_ a4 ^= t_istring) go to error4;
      79
      80      first = ivalue_ a2;
      81      last  = ivalue_ a3;
      82
stra 451$ check range of upper bound: a3 <= #a1
stra 452
stra 453      len1 = sc_nchars_ a1;  $ get length
stra 454
      84
stra 455      if last > len1 then
      86          call err_misc(41);
      87          go to error;
      88      end if;
      89
stra 458      if otype_ a4 = t_string then  $ short character string
stra 459          len4 = sc_nchars_ a4;  $ get length
stra 460          len = len1 + len4 - (last + 1 - first);
stra 461          if len = 0 then  $ result is null
stra 462              build_spec(ssubst, t_string, 0);
stra 463          elseif len <= sc_max then  $ result is short
stra 464              if len4 then  a1 = a4;  end if;
stra 465          else    $ len = 2
stra 466              ss = nulllc(len);  $ allocate result string
stra 467              ss_len(ss) = len;  $ set length
stra 468              icchar(ss, 1) = scchar(a4, 1);
stra 469              icchar(ss, 2) = scchar(a1, 1);
stra 470          end if;
stra 471      else    $ otype_ a4 = t_istring:  convert a1 to long string
stra 472          ss = nulllc(len1);  $ allocate null string block
stra 473          ss_len(ss) = len1;  $ set length of converted string
stra 474          if len1 then  icchar(ss, 1) = scchar(a1, 1);  end if;
stra 475          build_spec(a1, t_istring, ss);
stra 476          go to case(t_istring);
stra 477      end if;
stra 478
stra 479      return;
      91
      92
      93/case(t_atom)/                $ short atom
      94
      95/case(t_proc)/                $ procs
      96
      97/case(t_lab)/                 $ labels
      98
      99/case(t_latom)/               $ long atom
     100
     101      go to error1;
     102
     103
     104/case(t_elmt)/                $ compressed element
     105
     106      deref(a1);   go to switch;
     107
     108
     109/case(t_lint)/                $ long integer
     110
     111      go to error1;
     112
     113
     114/case(t_istring)/             $ long chars
     115
stra 480      if (otype_ a4 ^= t_string & otype_ a4 ^= t_istring) go to error4;
     117
     118      if (ivalue_ a3 > ss_len(value_ a1)) go to error2;
stra 481
stra 482      if otype_ a4 = t_string then  $ convert to long string
stra 483          len4 = sc_nchars_ a4;  $ get length
stra 484          ss = nulllc(len4);  $ allocate null string block
stra 485          ss_len(ss) = len1;  $ set length of converted string
stra 486          if len4 then  icchar(ss, 1) = scchar(a4, 1);  end if;
stra 487      end if;
     119
     120      ssubst = ssbsts(a1, a2, a3, a4);
     121
     122      return;
     123
     124
     125/case(t_real)/                $ real
     126
     127      go to error1;
     128
     129
     130/case(t_tuple)/               $ standard tuple
     131
     132/case(t_stuple)/              $ packed or untyped tuple
     133
     134      if (otype_ a4 ^= t_tuple & otype_ a4 ^= t_stuple)
     135          go to error4;
     136
     137      ssubst = ssbstt(a1, a2, a3, a4);
     138
     139      return;
     140
     141
     142/case(t_set)/                 $ set
     143
     144/case(t_map)/                 $ map
     145
     146      go to error1;
     147
     148
     149case_om;                      $ om type
     150
     151      call err_om(18);
     152
     153      go to error;
     154
     155
     156/error1/                      $ illegal type for -a1-
     157
     158      call err_type(54);
     159      a1 = err_val(f_gen);
     160
     161      return;
     162
     163
     164/error2/                      $ index out of range for strings
     165
     166      call err_misc(41);
     167      go to error;
     168
     169
     170/error4/                      $ incompatible types for -a1- and -a4-
     171
     172      call err_type(57);
     173
     174/error/                       $ assign proper error value to -a1-
     175
     176      if isprim(type_ a1) then
     177          a1 = err_val(f_gen);
     178      else
     179          a1 = err_val(hform(value_ a1));
     180      end if;
     181
     182      return;
     183
     184
     185      end fnct ssubst;
       1 .=member ssubstt
       2      fnct ssbstt(a1, a2, a3, a4);
       3
       4$ this routine performs -a1(a2 ... a3) := a4- on tuples.  since
       5$ this operation is relatively rare, it is performed by a series
       6$ of calls to the -of- and -sof- routines.
       7
       8$ n.b. -a1- and -a4- are specifiers for tuples
       9$      -a2- and -a3- are specifiers for short integers
      10$      1 <= a2 <= a3+1
      11
      12
      13      size a1(hs),            $ specifiers for arguments
      14           a2(hs),
      15           a3(hs),
      16           a4(hs);
      17
      18      size ssbstt(hs);        $ specifier returned
      19
      20      size indx1(hs),         $ index over -a1- as setl integer
      21           indx4(hs),         $ index over -a4- as setl integer
      22           indxs(hs),         $ index over -ssbstt-
      23           comp(hs);          $ component being copied
      24
      25      size len1(ps),          $ ?a1
      26           len4(ps);          $ ?a4
      27
      28      size first(ps),         $ index of first component
      29           last(ps),          $ index of last component
      30           len(ps),           $ length of result
      31           j(ps);             $ loop index
      32
      33      size nulltup(hs),       $ functions called
      34           copy1(hs);
      35
      36
      37      len1 = nelt(value_ a1); $ get lengths of tuples
      38      len4 = nelt(value_ a4);
      39
      40      first = ivalue_ a2;     $ get bounds of subtuple
      41      last  = ivalue_ a3;
      42
      43
      44$ compute nelt of result
      45
      46      len = len1 + len4 - (last + 1 - first);
      47
      48      ssbstt = a1;
      49
      50      if (len > maxindx(value_ ssbstt)) call exptup(ssbstt, len);
      51      if (is_shared_ ssbstt) ssbstt = copy1(ssbstt);
      52$
      53$ we distinguish two cases:
      54$
      55$ 1. ?ssubstt = ?a1:  we copy -a1- if it is shared, then copy -a4-
      56$                     into -a1- and return its specifier.
      57$
      58$ 2. ?ssubstt ^= ?a1: we allocate a new block, then copy the parts
      59$                     of -a1- and -a4- into this block and return
      60$                     its specifier.
      61$
      62      if len = len1 then
      63          indx1 = a2;
      64          indx4 = one;
      65
      66          do j = 1 to len4;
      67              call of(comp, a4, indx4);
      68              call sof(ssbstt, indx1, comp);
      69
      70              add1(indx1);
      71              add1(indx4);
      72          end do;
      73
      74      else                    $ # ssbstt /= # a1
      75          $ we would have to duplicate code if we expand, taking
      76          $ into account whether we expand or contract the tuple.
      77          if value_ ssbstt = value_ a1 then
      78              ssbstt = nulltup(hform(value_ ssbstt), len);
      79          end if;
      80
      81$ ssubstt( 1 ... (a2-1) )  :=  a1( 1 ... (a2-1) )
      82
      83          indx1 = one;
      84          indxs = one;
      85
      86          do j = 1 to first - 1;
      87              call of(comp, a1, indx1);
      88              call sof(ssbstt, indxs, comp);
      89
      90              add1(indx1);
      91              add1(indxs);
      92          end do;
      93
      94
      95$ ssubstt( a2 ... a2+?a4-1 )  :=  a4( 1 ... ?a4 )
      96
      97          indx4 = one;
      98
      99          do j = 1 to len4;
     100              call of(comp, a4, indx4);
     101              call sof(ssbstt, indxs, comp);
     102
     103              add1(indx4);
     104              add1(indxs);
     105          end do;
     106
     107
     108$ ssubstt( a2+?a4 ... ?ssubstt )  :=  a1( a3+1 ... ?a1 )
     109
     110          indx1 = a3;
     111
     112          do j = 1 to len1 - last;
     113              add1(indx1);
     114
     115              call of(comp, a1, indx1);
     116              call sof(ssbstt, indxs, comp);
     117
     118              add1(indxs);
     119          end do;
     120
     121          $ if we did not allocate a null tuple,  we  must  set  the re-
     122          $ maining components to the proper omega.   this must be done,
     123          $ since otherwise the okneltr routine will fail to compute the
     124          $ cardinality correctly.
     125          do j = len + 1 to len1;
     126              call sof(ssbstt, indxs, spec_om);
     127
     128              add1(indxs);
     129          end do;
     130
     131          nelt(value_ ssbstt) = len;
     132
     133      end if;
     134
     135
     136      end fnct ssbstt;
       1 .=member ssubsts
       2      fnct ssbsts(a1, a2, a3, a4);
       3
       4$ this routine performs -a1(a2...a3) := a4- on indirect strings.
       5
       6$ n.b. -a1- and -a4- are specifiers for indirect strings
       7$      -a2- and -a3- are specifiers for short integers
       8$      1 <= a2 <= a3+1 <= #a1+1
       9
      10
      11      size a1(hs),            $ specifiers for arguments
      12           a2(hs),
      13           a3(hs),
      14           a4(hs);
      15
      16      size ssbsts(hs);        $ specifier returned
      17
      18      size ss1(ssz),          $ string specifier for -a1-
      19           ss4(ssz),          $ string specifier for -a4-
      20           newss(ssz);        $ string specifier of result
      21
      22      size first(ps),         $ first character of substring
      23           last(ps),          $ last character of substring
      24           len1(ps),          $ length of -a1-
      25           len4(ps),          $ length of -a4-
      26           len(ps),           $ length of result
      27           temp(ps),          $ temporary end of result string
      28           j(ps);             $ loop index
      29
      30      size mvc_ss1(ssz);      $ string specifiers for system variables
      31      size mvc_ss2(ssz);
      32
      33      size nulllc(ssz);       $ function called
      34
      35
      36      $ unpack the arguments
      37      ss1   = value_  a1;   len1  = ss_len(ss1);
      38      ss4   = value_  a4;   len4  = ss_len(ss4);
      39      first = ivalue_ a2;   last  = ivalue_ a3;
      40
      41      $ assert that the global string specifiers have been allocated
      42      assert runtime_flag;
      43      mvc_ss1 = value(s_ss1);   mvc_ss2 = value(s_ss2);
      44$
      45$ compute the length of the result string, then allocate the result
      46$ string block
      47$
      48      len  = len1 + len4 - (last + 1 - first);
stra 488
stra 489      if len = 0 then  $ result is null string
stra 490          build_spec(ssbsts, t_string, 0);
stra 491      elseif len <= sc_max then  $ result is short
stra 492          ssbsts = spec_char;  $ one-character template
stra 493          if len4 then
stra 494              scchar(ssbsts, 1) = icchar(ss4, 1);
stra 495          else
stra 496              scchar(ssbsts, 1) = icchar(ss1, 1);
stra 497          end if;
stra 498          return;
stra 499      end if;
      49
      50      newss = nulllc(len);
      51      ss_len(newss) = len;
      52      build_spec(ssbsts, t_istring, newss);
      53
      54      ss_ptr(mvc_ss1) = ss_ptr(newss);
      55      ss_ofs(mvc_ss1) = ss_ofs(newss);
      56      ss_len(mvc_ss1) = len;
      57
      58$ ssubsts( 1 ... (a2-1) )  :=  a1( 1 ... (a2-1) )
      59
      60      temp = first - 1;       $ temp := (a2-1)
      61
      62      ss_ptr(mvc_ss2) = ss_ptr(ss1);
      63      ss_ofs(mvc_ss2) = ss_ofs(ss1);
      64      ss_len(mvc_ss2) = len1;
      65
      66      mvc(mvc_ss1, mvc_ss2, temp);
      67
      68$ ssubsts( (a2-1)+1 ... (a2-1)+?a4 )  :=  a4( 1 ... ?a4 )
      69
      70      ss_ofs(mvc_ss1) = ss_ofs(mvc_ss1) + temp;
      71      ss_len(mvc_ss1) = ss_len(mvc_ss1) - temp;
      72
      73      mvc(mvc_ss1, ss4, len4);
      74
      75$ ssubsts( (a2-1+?a4)+1 ... ?ssubsts )  :=  a1( a3+1 ... ?a1 )
      76
      77      ss_ofs(mvc_ss1) = ss_ofs(mvc_ss1) + len4;
      78      ss_len(mvc_ss1) = ss_len(mvc_ss1) - len4;
      79
      80      ss_ofs(mvc_ss2) = ss_ofs(mvc_ss2) + last;
      81      ss_len(mvc_ss2) = ss_len(mvc_ss2) - last;
      82
      83      mvc(mvc_ss1, mvc_ss2, ss_len(mvc_ss2));
      84
      85
      86      end fnct ssbsts;
       1 .=member endop
       2      fnct endop(s1, low);
       3
       4$ this routine performs -s(low...)-.  it treats this construct
       5$ as a shorthand for -s(low... ?s)-.
       6
       7
       8      size s1(hs);            $ specifier for string or tuple
       9      size low(hs);           $ specifier for lower bound
      10
      11      size endop(hs);         $ specifier returned
      12
      13      size s(hs);             $ local copy of s1
      14      size tp(ps),            $ type of s
      15           high(hs);          $ ?s as short integer
      16
      17      size subst(hs);         $ substring function
      18
      19
      20      s = s1;    deref(s);
      21      tp = type_ s;           $ find type of -s-
      22
      23      high = 0;               $ set otype_ high = t_int
      24
      25      if tp = t_string then   $ find ?s
      26          ivalue_ high = sc_nchars_ s;
      27
      28      elseif tp = t_istring then
      29          ivalue_ high = ss_len(value_ s);
      30
      31      elseif istuple(tp) then
      32          ivalue_ high = nelt(value_ s);
      33
      34      else
      35          call err_type(40);
      36          endop = err_val(f_gen);
      37          return;
      38
      39      end if;
      40
      41      endop = subst(s, low, high);
      42
      43
      44      end fnct endop;
       1 .=member send
       2      fnct send(s1, low, y);
       3
       4$ this routine performs -s(low...) := y-.  it treats this
       5$ construct as a shorthand for -s(low ... ?s) := y-.
       6$ it does it by calling -ssubst-.
       7
       8
       9      size s1(hs);            $ specifier for string or tuple
      10      size low(hs);           $ specifier for lower bound
      11      size y(hs);             $ specifier for right-hand side
      12
      13      size send(hs);          $ specifier returned
      14
      15      size s(hs);             $ local copy of s1
      16      size tp(ps),            $ type of s
      17           high(hs);          $ length of substring as short int
      18
      19      size ssubst(hs);        $ function called
      20
      21
      22      s = s1;    deref(s);
      23      tp = type_ s;           $ find type of -s-
      24
      25      high = 0;               $ set otype_ high = t_int
      26
      27      if tp = t_string then   $ find ?s
      28          ivalue_ high = sc_nchars_ s;
      29
      30      elseif tp = t_istring then
      31          ivalue_ high = ss_len(value_ s);
      32
      33      elseif istuple(tp) then
      34          ivalue_ high = nelt(value_ s);
      35
      36      else
      37          call err_type(41);
      38          send = err_val(f_gen);
      39          return;
      40
      41      end if;
      42
      43      send = ssubst(s, low, high, y);
      44
      45
      46      end fnct send;
       1 .=member lt
       2      fnct lt(arg1, arg2);
       3
       4$ this is the setl less than function. it returns 0 or 1
       5$ as its value.
       6
       7$ less than may be applied to integers, reals, and strings.
       8$ we compare two characters by comparing their internal
       9$ character codes; one string is less than another if it
      10$ would appear first in the phone book.
      11
      12
      13      size arg1(hs);          $ specifier for left operand
      14      size arg2(hs);          $ specifier for right operand
      15
      16      size lt(1);             $ boolean value returned
      17
      18      size a1(hs);            $ local copy of left operand
      19      size a2(hs);            $ local copy of right operand
      20
      21      size ss1(ssz);          $ string specifier for left operand
stra 500      size len1(ps);          $ length of left operand
      22      size ss2(ssz);          $ string specifier for right operand
stra 501      size len2(ps);          $ length of right operand
      23      size len(ps);           $ length of string
      24      size cc(ps);            $ condition code
      25      size j(ps);             $ loop index
      26      size c1(chsiz);         $ characters
      27      size c2(chsiz);
      28
      29      real real1, real2;      $ real temporaries
mjsa 124
mjsa 125      size ltli(1);           $ computes lt for long integers
      30
      31
      32      a1 = arg1;   deref(a1);
      33      a2 = arg2;   deref(a2);
      34
      35      go to case(otype_ a1) in t_min to t_max;
      36
      37
mjsa 126/case(t_int)/                 $ short integer
mjsa 127
mjsa 128$ call the arbitrary precision arithmetic package if a2 is long
mjsa 129
mjsa 130      if otype_ a2 = t_int then
mjsa 131          lt = (ivalue_ a1 < ivalue_ a2);
mjsa 132
mjsa 133      elseif otype_ a2 = t_lint then
mjsa 134          lt = ltli(a1, a2);
mjsa 135
mjsa 136      else
mjsa 137          go to error;
mjsa 138      end if;
mjsa 139
mjsa 140      return;
      53
      54
      55/case(t_string)/      $ short chars
      56
stra 502      len1 = sc_nchars_ a1;  $ get length of left operand
stra 503
stra 504      if otype_ a2 = t_istring then
stra 505          ss2 = value_ a2;  len2 = ss_len(ss2);
stra 506          len = len1;  if (len2 < len) len = len2;
stra 507          if len then  $ non-trivial, must compare characters
stra 508              c1 = scchar(a1, 1);  c2 = icchar(ss2, 1);
stra 509              if c1 ^= c2 then  lt = (c1 < c2); return;  end if;
stra 510          end if;
stra 511          lt = (len1 < len2);
stra 512
stra 513      elseif otype_ a2 = t_string then
stra 514          len2 = sc_nchars_ a2;
stra 515          len = len1;  if (len2 < len) len = len2;
stra 516          if len then  $ non-trivial, must compare characters
stra 517              c1 = scchar(a1, 1);  c2 = scchar(a2, 1);
stra 518              if c1 ^= c2 then  lt = (c1 < c2); return;  end if;
stra 519          end if;
stra 520          lt = (len1 < len2);
stra 521
stra 522      else
stra 523          go to error;
stra 524      end if;
stra 525
      79      return;
      80
      81
      82/case(t_atom)/       $ short atom
      83
      84/case(t_proc)/
      85
      86/case(t_lab)/
      87
      88/case(t_latom)/      $ 'long' atom
      89
      90/case(t_elmt)/       $ compressed element
      91
      92      go to error;
      93
      94
mjsa 141/case(t_lint)/                $ long integer
mjsa 142
mjsa 143$ call the arbitrary precision arithmetic package since a1 is long
mjsa 144
mjsa 145      if otype_ a2 = t_int ! otype_ a2 = t_lint then
mjsa 146          lt = ltli(a1, a2);
mjsa 147      else
mjsa 148          go to error;
mjsa 149      end if;
mjsa 150
mjsa 151      return;
     110
     111
     112/case(t_istring)/     $ long chars
     113
stra 526      ss1 = value_ a1;  len1 = ss_len(ss1);
stra 527
stra 528      if otype_ a2 = t_string then
stra 529          len2 = sc_nchars_ a2;
stra 530          len = len1;  if (len2 < len) len = len2;
stra 531          if len then  $ non-trivial, must compare characters
stra 532              c1 = icchar(ss1, 1);  c2 = scchar(a2, 1);
stra 533              if c1 ^= c2 then  lt = (c1 < c2); return;  end if;
stra 534          end if;
stra 535          lt = (len1 < len2);
stra 536
stra 537      elseif otype_ a2 = t_istring then
stra 538          ss2 = value_ a2;  len2 = ss_len(ss2);
stra 539          len = len1;  if (len2 < len) len = len2;
stra 540          clc(cc, ss1, ss2, len);
stra 541          if cc = 0 then
stra 542              lt = (len1 < len2);
stra 543          else
stra 544              lt = (cc = 1);
stra 545          end if;
stra 546
stra 547      else
stra 548          go to error;
stra 549      end if;
     129
     130      return;
     131
     132
     133/case(t_real)/       $ real
     134
     135      if (otype_ a2 ^= t_real) go to error;
     136
     137      real1 = rval(value_ a1);
     138      real2 = rval(value_ a2);
     139      lt    = (real1 < real2);
     140
     141      return;
     142
     143
     144/case(t_tuple)/      $ standard tuple
     145
     146/case(t_stuple)/     $ packed or untyped tuple
     147
     148/case(t_set)/        $ set
     149
     150/case(t_map)/        $ map
     151
     152      go to error;
     153
     154
     155case_om;    $ om type
     156
     157      call err_om(19);
     158
     159      lt = no;
     160
     161      return;
     162
     163/error/    $ illegal argument type
     164
     165      call err_type(42);
     166      lt = no;
     167
     168      return;
     169
     170
     190      end fnct lt;
       1 .=member even
       2      fnct even(arg);
       3
       4$ this is the setl 'even' predicate
       5
       6      size arg(hs);  $ specifier for integer
       7
       8      size even(1);  $ flag returned
       9
      10      size val(hs);  $ value of integer
mjsa 152
mjsa 153      size evenli(1);
      11
      12
mjsa 154      if otype_ arg = t_int then
mjsa 155 .+s10    even = ( ^ .f. 1, 1, arg);
mjsa 156 .+s20    even = ( ^ .f. 1, 1, arg);
mjsa 157 .+r32    even = ( ^ .f. 3, 1, arg);
mjsa 158 .+s66    even = ( ^ .f. 1, 1, arg);
mjsa 159      else
mjsa 160          even = evenli(arg);
mjsa 161      end if;
      17
      18
      19      end fnct even;
       1 .=member min
       2      fnct smin(a, b);
       3
       4$ this routine returns the minimum of two values a and b.
       5$ min is defined on integers, reals, and strings. the
       6$ minimum of two strings is the one which would appear
       7$ first in the telephone book according to some machine
       8$ dependant collating sequence.
       9
      10
      11      size a(hs),   $ items being compared
      12           b(hs);
      13
      14      size smin(hs);          $ specifier returned
      15
      16      size lt(1);   $ setl less than function
      17
      18
      19      if lt(a, b) then
      20          smin = a;
      21      else
      22          smin = b;
      23      end if;
      24
      25
      26      end fnct smin;
       1 .=member max
       2      fnct smax(a, b);
       3
       4$ this routine returns the maximum of two values a and b.
       5$ max is defined on integers, reals, and strings. the
       6$ maximum of two strings is the one which would appear
       7$ last in the telephone book according to some machine
       8$ dependant collating sequence.
       9
      10
      11      size a(hs),   $ items being compared
      12           b(hs);
      13
      14      size smax(hs);          $ specifier returned
      15
      16      size lt(1);   $ setl less than function
      17
      18
      19      if lt(a, b) then
      20          smax = b;
      21      else
      22          smax = a;
      23      end if;
      24
      25
      26      end fnct smax;
       1 .=member addli
mjsa 162$ arbitrary precision arithmetic package
mjsa 163$ --------- --------- ---------- -------
mjsa 164
mjsa 165$ the setl arbitrary precision arithmetic package consists of a number
mjsa 166$ of functions whose arguments may be long or short integer specifiers,
mjsa 167$ and which return the specifier for a long or short integer.  the
mjsa 168$ following routines are provided:
mjsa 169$
mjsa 170$ the main set of arithmetic routines are:
mjsa 171$
mjsa 172$   fnct addli(arg1, arg2)      addition of integers
mjsa 173$   fnct diffli(arg1, arg2)     subtraction of integers
mjsa 174$   fnct multli(arg1, arg2)     multiplication
mjsa 175$   fnct divli(arg1, arg2)      division
mjsa 176$   fnct modli(arg1, arg2)      mod
mjsa 177$
mjsa 178$   fnct uminli(arg1)           unary minus
mjsa 179$
mjsa 180$ the following predicates on setl integers return a little value of yes
mjsa 181$ or no (1 or 0).
mjsa 182$
mjsa 183$   fnct equalli(arg1, arg2)    =
mjsa 184$   fnct ltli(arg1, arg2)       <
mjsa 185$   fnct evenli(arg1, arg2)     check for even integer
mjsa 186$
mjsa 187$ the following routines perform transformations between setl integer
mjsa 188$ and real values:
mjsa 189$
mjsa 190$   fnct floatli(arg1)          floating point from integer
mjsa 191$   fnct fixli(arg1)            returns long int from real notation
mjsa 192$
mjsa 193$ the following functions aid in performing input/output on integers.
mjsa 194$
mjsa 195$   fnct strli(arg1)            transform integer to string
mjsa 196$   fnct putbli(arg1)           output for long integers
mjsa 197$   fnct getbli(arg1)           input for long integers
mjsa 198$
mjsa 199$ the following functions perform miscellaneous tasks.
mjsa 200$
mjsa 201$   fnct putintli(arg1)         transform little integer to setl int
mjsa 202$   fnct getintli(arg1)         transform setl integer to little int
mjsa 203$   fnct hashli(arg1)           integrates long int into sets
mjsa 204$   fnct valli(arg1)            transform string to integer
mjsa 205$
mjsa 206$ in addition, the following routines are provided but should never
mjsa 207$ be called from outside this package:
mjsa 208$
mjsa 209$   fnct intad1(arg1, arg2)     add long int to short int
mjsa 210$   fnct intad2(arg1, arg2)     add long int to long int
mjsa 211$   fnct intsb1(arg1, arg2)     sub abs(long int) from short int
mjsa 212$   fnct intsb2(arg1, arg2)     sub abs(long int) from abs(long int)
mjsa 213$   fnct intdiv(arg1, arg2)     divide a long int by long int
mjsa 214$   fnct trlint(arg1)           transform short int to long int
mjsa 215
mjsa 216
mjsa 217$ long integer arithmetic functions
mjsa 218$ ---- ------- ---------- ---------
mjsa 219
mjsa 220
mjsa 221      fnct addli(arg1, arg2);
mjsa 222
mjsa 223$ this routine takes as its arguments the specifiers to two integers
mjsa 224$ and returns the specifier to the sum of these two integers.  it
mjsa 225$ normally calls the auxiliary additions and subtraction routines
mjsa 226$ to perform the calculations, although it does try to catch certain
mjsa 227$ special cases (namely short negative and short positive integers)
mjsa 228$ in-line.
mjsa 229
mjsa 230      size addli(hs);         $ integer specifier returned
mjsa 231
mjsa 232      size arg1(hs);          $ arguments are integer specifiers
mjsa 233      size arg2(hs);
mjsa 234
mjsa 235      size p1(ps);            $ pointer to data block for arg1
mjsa 236      size p2(ps);            $ pointer to data block for arg2
mjsa 237      size ptr(ps);           $ pointer to data block for addli
mjsa 238      size s1(1);             $ sign of arg1
mjsa 239      size s2(1);             $ sign of arg2
mjsa 240      size temp(ws);          $ stores value of small sums
mjsa 241
mjsa 242      size intad1(hs);        $ functions used
mjsa 243      size intad2(hs);
mjsa 244      size intsb1(hs);
mjsa 245      size intsb2(hs);
mjsa 246      size ltli(1);
mjsa 247
mjsa 248
mjsa 249      if otype_ arg1 = t_int & otype_ arg2 = t_int then
mjsa 250
mjsa 251          temp = ivalue_ arg1 + ivalue_ arg2;
mjsa 252          if temp <= maxsi then  $ result fits in specifier
mjsa 253              build_spec(addli, t_int, temp);
mjsa 254          else    $ result requires data block
mjsa 255              build_lint1(addli, temp, positive);
mjsa 256          end if;
mjsa 257
mjsa 258      elseif otype_ arg1 = t_int & otype_ arg2 = t_lint then
mjsa 259
mjsa 260          p2 = value_ arg2;
mjsa 261          if li_snint(p2) then
mjsa 262              temp = ivalue_ arg1 - li_ddigit(p2, 1);
mjsa 263              if temp >= 0 then
mjsa 264                  build_spec(addli, t_int, temp);
mjsa 265              else
mjsa 266                  build_lint1(addli, iabs(temp), negative);
mjsa 267               end if;
mjsa 268           elseif li_pos(p2) then
mjsa 269               addli = intad1(arg2, arg1, positive);
mjsa 270           else
mjsa 271               addli = intsb1(arg2, arg1, negative);
mjsa 272           end if;
mjsa 273
mjsa 274      elseif otype_ arg1 = t_lint & otype_ arg2 = t_int then
mjsa 275
mjsa 276           p1 = value_ arg1;
mjsa 277           if li_snint(p1) then
mjsa 278               temp = ivalue_ arg2 - li_ddigit(p1, 1);
mjsa 279               if temp >= 0 then
mjsa 280                   build_spec(addli, t_int, temp);
mjsa 281               else
mjsa 282                   build_lint1(addli, iabs(temp), negative);
mjsa 283               end if;
mjsa 284           elseif li_pos(p1) then
mjsa 285               addli = intad1(arg1, arg2, positive);
mjsa 286           else
mjsa 287               addli = intsb1(arg1, arg2, negative);
mjsa 288           end if;
mjsa 289
mjsa 290      elseif otype_ arg1 = t_lint & otype_ arg2 = t_lint then
mjsa 291
mjsa 292$ two long integers:  if the signs of the two integers are the same we
mjsa 293$ can simply call the long integer addition routine, setting the the
mjsa 294$ sign of the answer to be the same as that of either one of its
mjsa 295$ arguments.  if one of the integers is positive and the other is
mjsa 296$ negative, then we save the signs of the two arguments and temporarly
mjsa 297$ set both arguments to their absolute value. we do this so that we can
mjsa 298$ compare the magnitudes of the two numbers using the function -ltli-
mjsa 299$ without having to recopy either of the two integers.  before leaving
mjsa 300$ the routine we restore both of the arguments to their original sign.
mjsa 301
mjsa 302          p1 = value_ arg1;
mjsa 303          p2 = value_ arg2;
mjsa 304
mjsa 305          if li_sign(p1) = li_sign(p2) then
mjsa 306
mjsa 307              addli = intad2(arg1, arg2, li_sign(p1));
mjsa 308
mjsa 309          else    $ the signs differ
mjsa 310
mjsa 311              s1 = li_sign(p1);
mjsa 312              s2 = li_sign(p2);
mjsa 313              li_sign(p1) = positive;
mjsa 314              li_sign(p2) = positive;
mjsa 315
mjsa 316              if ltli(arg1, arg2) then
mjsa 317                  addli = intsb2(arg2, arg1, s2);
mjsa 318              else
mjsa 319                  addli = intsb2(arg1, arg2, s1);
mjsa 320              end if;
mjsa 321
mjsa 322              li_sign(p1) = s1;
mjsa 323              li_sign(p2) = s2;
mjsa 324
mjsa 325          end if;
mjsa 326
mjsa 327      else  $ one of the arguments is om
mjsa 328          call err_om(13);
mjsa 329          addli = err_val(f_int);
mjsa 330      end if;
mjsa 331
mjsa 332
mjsa 333      end fnct addli;
       1 .=member diffli
mjsa 334      fnct diffli(arg1, arg2);
mjsa 335
mjsa 336$ this routine takes as its arguments the specifiers to two integers
mjsa 337$ and returns the specifier to the difference of these two integers.
mjsa 338$ it normally calls the auxiliary additions and subtraction
mjsa 339$ routines to perform the calculations, although it does try to catch
mjsa 340$ certain special cases (namely short negative and short positive
mjsa 341$ integers) in-line.
mjsa 342
mjsa 343      size diffli(hs);        $ integer specifier returned
mjsa 344
mjsa 345      size arg1(hs);          $ arguments are integer specifiers
mjsa 346      size arg2(hs);
mjsa 347
mjsa 348      size p1(ps);            $ pointers to data blocks
mjsa 349      size p2(ps);
mjsa 350      size ptr(ps);
mjsa 351      size s1(1);             $ sign of argument 1
mjsa 352      size s2(1);             $ sign of argument 2
mjsa 353      size temp(ws);          $ temporary values of differences
mjsa 354
mjsa 355      size intad1(hs);        $ add long to short int
mjsa 356      size intad2(hs);        $ add long to long int
mjsa 357      size intsb1(hs);        $ subtract short from long int
mjsa 358      size intsb2(hs);        $ subtract long int from long int
mjsa 359      size ltli(hs);          $ less than for long integers
mjsa 360
mjsa 361$ although we break down the subtraction of two numbers into the
mjsa 362$ standard four cases, we also check within the first case for a
mjsa 363$ subtraction which will result in a short integer (or a negative
mjsa 364$ integer whose magnitude is less than maxsi.
mjsa 365
mjsa 366       if otype_ arg1 = t_int & otype_ arg2 = t_int then
mjsa 367
mjsa 368          temp = ivalue_ arg1 - ivalue_ arg2;
mjsa 369          if temp >= 0 then
mjsa 370              build_spec(diffli, t_int, temp);
mjsa 371          else
mjsa 372              build_lint1(diffli, iabs(temp), negative);
mjsa 373          end if;
mjsa 374
mjsa 375      elseif otype_ arg1 = t_int & otype_ arg2 = t_lint then
mjsa 376
mjsa 377          p2 = value_ arg2;
mjsa 378          if li_snint(p2) then
mjsa 379              temp = ivalue_ arg1 + li_ddigit(p2, 1);
mjsa 380              if temp <= maxsi then
mjsa 381                  build_spec(diffli, t_int, temp);
mjsa 382              else
mjsa 383                  build_lint1(diffli, iabs(temp), positive);
mjsa 384              end if;
mjsa 385          elseif li_pos(p2) then
mjsa 386              diffli = intsb1(arg2, arg1, negative);
mjsa 387          else
mjsa 388              diffli = intad1(arg2, arg1, positive);
mjsa 389          end if;
mjsa 390
mjsa 391      elseif otype_ arg1 = t_lint & otype_ arg2 = t_int then
mjsa 392
mjsa 393          if li_pos(value_ arg1) then
mjsa 394              diffli = intsb1(arg1, arg2, positive);
mjsa 395          else
mjsa 396              diffli = intad1(arg1, arg2, negative);
mjsa 397          end if;
mjsa 398
mjsa 399      elseif otype_ arg1 = t_lint & otype_ arg2 = t_lint then
mjsa 400
mjsa 401          p1 = value_ arg1;
mjsa 402          p2 = value_ arg2;
mjsa 403
mjsa 404          if li_sign(p1) ^= li_sign(p2) then
mjsa 405
mjsa 406              diffli = intad2(arg1, arg2, li_sign(p1));
mjsa 407
mjsa 408          else    $ the signs are the same
mjsa 409
mjsa 410              s1 = li_sign(p1);
mjsa 411              s2 = li_sign(p2);
mjsa 412              li_sign(p1) = positive;
mjsa 413              li_sign(p2) = positive;
mjsa 414
mjsa 415              if ltli(arg1, arg2) then
mjsa 416                  diffli = intsb2(arg2, arg1, (s1=no));
mjsa 417              else
mjsa 418                  diffli = intsb2(arg1, arg2, s1);
mjsa 419              end if;
mjsa 420
mjsa 421              li_sign(p1) = s1;
mjsa 422              li_sign(p2) = s2;
mjsa 423
mjsa 424          end if;
mjsa 425
mjsa 426      else  $ one of the arguments is om
mjsa 427          call err_om(13);
mjsa 428          diffli = err_val(f_int);
mjsa 429      end if;
mjsa 430
mjsa 431
mjsa 432      end fnct diffli;
       1 .=member divli
mjsa 433      fnct divli(arg1, arg2);
mjsa 434
mjsa 435$ this function returns the value of the first argument divided by
mjsa 436$ the second argument.  it first checks to see if the dividend and
mjsa 437$ the divisor both have absolute values less than maxsi.  if so
mjsa 438$ the division is performed in-line, otherwise a call to intdiv
mjsa 439$ is made.
mjsa 440
mjsa 441      size divli(hs);         $ integer specifier returned
mjsa 442
mjsa 443      size arg1(hs);          $ arguments are integer specifiers
mjsa 444      size arg2(hs);
mjsa 445
mjsa 446      size p1(ps);            $ pointers to long int data blocks
mjsa 447      size p2(ps);
mjsa 448      size ptr(ps);
mjsa 449      size temp(ws);          $ used for temporary results
mjsa 450
mjsa 451      size trlint(hs);        $ transfrom short to long int
mjsa 452      size intdiv(hs);        $ long integer division routine
mjsa 453      size equalli(hs);       $ equality for long integers
mjsa 454
mjsa 455$ the simple case consists of two short integers.  since both arguments
mjsa 456$ must be positive, and since the magnitude of the result must be
mjsa 457$ smaller than maxsi, we can can be sure that the result will be a short
mjsa 458$ integer.
mjsa 459
mjsa 460      if otype_ arg1 = t_int & otype_ arg2 = t_int then
mjsa 461
mjsa 462          if (ivalue_ arg2 = 0) go to error1;
mjsa 463
mjsa 464          build_spec(divli, t_int, ivalue_ arg1 / ivalue_ arg2);
mjsa 465
mjsa 466$ the two mixed cases (t_int and t_lint) are not symetrical since if the
mjsa 467$ first argument is a short integer, we know that the result of the
mjsa 468$ division must be smaller than or equal to that short integer.  we take
mjsa 469$ advantage of this knowledge below.
mjsa 470
mjsa 471      elseif otype_ arg1 = t_int & otype_ arg2 = t_lint then
mjsa 472
mjsa 473          p2 = value_ arg2;
mjsa 474          if li_nddig(p2) = 1 then
mjsa 475              temp = ivalue_ arg1 / li_ddigit(p2, 1);
mjsa 476              if temp = 0 then
mjsa 477                  divli = zero;
mjsa 478              elseif li_pos(p2) then
mjsa 479                  build_spec(divli, t_int, temp);
mjsa 480              else    $ temp ^= 0 & li_neg(p2)
mjsa 481                  build_lint1(divli, temp, negative);
mjsa 482              end if;
mjsa 483          else
mjsa 484              divli = intdiv(trlint(arg1), arg2, 1);
mjsa 485          end if;
mjsa 486
mjsa 487$ here we have the case of a long and a short integer argument.  we
mjsa 488$ must do a bit more checking here to see if the result of the division
mjsa 489$ can fit into a short integer format.  we must also check for
mjsa 490$ division by zero since the divisor is a short integer.
mjsa 491
mjsa 492      elseif otype_ arg1 = t_lint & otype_ arg2 = t_int then
mjsa 493
mjsa 494          if (ivalue_ arg2 = 0) go to error1;
mjsa 495
mjsa 496          p1 = value_ arg1;
mjsa 497          if li_nddig(p1) = 1 then
mjsa 498              temp = li_ddigit(p1, 1) / ivalue_ arg2;
suna  57              if temp = 0 then
suna  58                  divli = zero;
suna  59              elseif temp <= maxsi & li_pos(p1) then
mjsa 500                  build_spec(divli, t_int, temp);
mjsa 501              else
mjsa 502                  build_lint1(divli, temp, li_sign(p1));
mjsa 503              end if;
mjsa 504          else
mjsa 505              divli = intdiv(arg1, trlint(arg2), 1);
mjsa 506          end if;
mjsa 507
mjsa 508$ the division can be performed in-line if both of the operands are
mjsa 509$ integers whose magnitude fits into one machine word.  if they do not,
mjsa 510$ we call the lower level division routine.
mjsa 511
mjsa 512      elseif otype_ arg1 = t_lint & otype_ arg2 = t_lint then
mjsa 513
mjsa 514          p1 = value_ arg1;   p2 = value_ arg2;
mjsa 515
mjsa 516          if li_nddig(p1) = 1 & li_nddig(p2) = 1 then
mjsa 517              temp = li_ddigit(p1, 1) / li_ddigit(p2, 1);
mjsa 518              if (li_sign(p1) ^= li_sign(p2)) temp = -temp;
mjsa 519              put_intval(temp, divli);
mjsa 520          else
mjsa 521              divli = intdiv(arg1, arg2, 1);
mjsa 522          end if;
mjsa 523
mjsa 524      else    $ one of the arguments is om
mjsa 525          call err_om(13);
mjsa 526          divli = err_val(f_int);
mjsa 527      end if;
mjsa 528
mjsa 529      return;
mjsa 530
mjsa 531
mjsa 532/error1/                      $ zero-divide check
mjsa 533
mjsa 534      call err_misc(01);
mjsa 535      divli = err_val(f_int);
mjsa 536      return;
mjsa 537
mjsa 538
mjsa 539      end fnct divli;
       1 .=member modli
mjsa 540      fnct modli(arg1, arg2);
mjsa 541
mjsa 542$ this function returns the mod (the remainder) of arg1 divided by arg2.
mjsa 543$ if the dividend and the divisor are are both smaller than maxsi, the
mjsa 544$ calculation is performed in-line, otherwise a call to intdiv is made.
mjsa 545$ n.b.  the definition of mod differs in little and setl. as a result,
mjsa 546$ we use the little -mod- function to help us in calculating the setl
mjsa 547$ mod, but must make adjustments to reflect the difference in their
mjsa 548$ definitions.
mjsa 549
mjsa 550      size modli(hs);         $ integer specifier returned
mjsa 551
mjsa 552      size arg1(hs);          $ arguments are integer specifiers
mjsa 553      size arg2(hs);
mjsa 554
mjsa 555      size intdiv(hs);        $ long integer division routine
mjsa 556      size temp(ws);          $ temporary results
mjsa 557      size trlint(hs);        $ transform short to long int
mjsa 558
mjsa 559$ if both of the integers are short, then we can do the division inline.
mjsa 560$ otherwise, we transform the short integers to a long integer format
mjsa 561$ and then call function intdiv with an -op- parameter of 2.
mjsa 562
mjsa 563      if otype_ arg1 = t_int & otype_ arg2 = t_int then
mjsa 564
mjsa 565          if (ivalue_ arg2 = 0) go to error1;
mjsa 566
mjsa 567          temp = mod(ivalue_ arg1, ivalue_ arg2);
mjsa 568          build_spec(modli, t_int, temp);
mjsa 569
mjsa 570      elseif otype_ arg1 = t_int & otype_ arg2 = t_lint then
mjsa 571
mjsa 572          modli = intdiv(trlint(arg1), arg2, 2);
mjsa 573
mjsa 574      elseif otype_ arg1 = t_lint & otype_ arg2 = t_int then
mjsa 575
mjsa 576          if (ivalue_ arg2 = 0) go to error1;
mjsa 577
mjsa 578          modli = intdiv(arg1, trlint(arg2), 2);
mjsa 579
mjsa 580      elseif otype_ arg1 = t_lint & otype_ arg2 = t_lint then
mjsa 581
mjsa 582          modli = intdiv(arg1, arg2, 2);
mjsa 583
mjsa 584      else    $ one of the arguments is om
mjsa 585          call err_om(13);
mjsa 586          modli = err_val(f_int);
mjsa 587      end if;
mjsa 588
mjsa 589      return;
mjsa 590
mjsa 591
mjsa 592/error1/                      $ zero-divide check
mjsa 593
mjsa 594      call err_misc(01);
mjsa 595      modli = err_val(f_int);
mjsa 596      return;
mjsa 597
mjsa 598
mjsa 599      end fnct modli;
       1 .=member multli
mjsa 600      fnct multli(arg1, arg2);
mjsa 601
mjsa 602$ function multiplies two integers, either short or long, and returns
mjsa 603$ the specifier to a long or short integer result.
mjsa 604
mjsa 605      size multli(hs);        $ integer specifier returned
mjsa 606
mjsa 607      size arg1(hs);          $ arguments are integer specifiers
mjsa 608      size arg2(hs);
mjsa 609
mjsa 610      size p1(ps);            $ pointer to data block for arg1
mjsa 611      size p2(ps);            $ pointer to data block for arg2
mjsa 612      size ptr(ps);           $ pointer to data block of result multli
mjsa 613      size nd1(ws);           $ number of digits in arg1
mjsa 614      size nd2(ws);           $ number of digits in arg2
mjsa 615      size temp(ws);          $ used to store temporary values of mult
mjsa 616      size carry(ws);         $ carry
mjsa 617      size i(ps);             $ loop index
mjsa 618      size j(ps);             $ loop index
mjsa 619
mjsa 620      size trlint(hs);        $ functions used
mjsa 621
mjsa 622$ since there is no easy way to check whether the result will be less
mjsa 623$ than maxsi in the case of two short integers, we change any arguments
mjsa 624$ which happen to be short integers into their long integer form,
mjsa 625$ perform the multiplication, and then make sure that the result is
mjsa 626$ represented correctly as a long or short integer.
mjsa 627
mjsa 628      if is_om_ arg1 ! is_om_ arg2 then
mjsa 629          call err_om(13);
mjsa 630          multli = err_val(f_int);
mjsa 631          return;
mjsa 632      end if;
mjsa 633
mjsa 634      if type_ arg1 = t_int then
mjsa 635          if ivalue_ arg1 = 0 then
mjsa 636              multli = zero;
mjsa 637              return;
mjsa 638          else
mjsa 639              p1 = value_ trlint(arg1);
mjsa 640          end if;
mjsa 641      else
mjsa 642          p1 = value_ arg1;
mjsa 643      end if;
mjsa 644
mjsa 645      if type_ arg2 = t_int then
mjsa 646          if ivalue_ arg2 = 0 then
mjsa 647              multli = zero;
mjsa 648              return;
mjsa 649          else
mjsa 650              p2 = value_ trlint(arg2);
mjsa 651          end if;
mjsa 652      else
mjsa 653          p2 = value_ arg2;
mjsa 654      end if;
mjsa 655
mjsa 656      nd1 = li_ndig(p1);
mjsa 657      nd2 = li_ndig(p2);
mjsa 658
mjsa 659      $ allocate a long integer for the result;  initialize it to zero.
mjsa 660      get_lint((nd1 + nd2 + 1)/ 2, ptr);
mjsa 661      do j = hl_lint to li_nwords(ptr);
mjsa 662          heap(ptr+j) = 0;
mjsa 663      end do;
mjsa 664      build_spec(multli, t_lint, ptr);
mjsa 665
mjsa 666$ perform the multiplication, adding the partial sums as we go along.
mjsa 667
mjsa 668      do j = 1 to nd2;
mjsa 669          carry = 0;
mjsa 670          do i = 1 to nd1;
mjsa 671              temp = (li_digit(p1, i) * li_digit(p2, j))
mjsa 672                      + li_digit(ptr, j+(i-1))
mjsa 673                      + carry;
mjsa 674              li_digit(ptr, j+(i-1)) = temp;
mjsa 675              carry = temp / li_bas;
mjsa 676          end do;
mjsa 677          li_digit(ptr, j+nd1) = carry;
mjsa 678      end do;
mjsa 679
mjsa 680$ if the leading digit of the result is zero, then the number of digits
mjsa 681$ in the result is one less than the sum of the number of digits of the
mjsa 682$ operands.  we exclusive-or the sign of the operands to get the sign
mjsa 683$ of the result.  we do not need to check for an odd number of digits
mjsa 684$ to zero out the extra digit since the algorithm required that we zero
mjsa 685$ the result initially.
mjsa 686
mjsa 687      li_sign(ptr) = (li_sign(p1) ^= li_sign(p2));
mjsa 688      li_ndig(ptr) = nd1 + nd2 - (li_digit(ptr, nd1 + nd2) = 0);
mjsa 689
mjsa 690$ although the case of multiplication by two short integers will be
mjsa 691$ caught by the interpreter, it is still possible that two small
mjsa 692$ integers were multiplied to yield a short integer.
mjsa 693
mjsa 694      if li_spint(ptr) then
mjsa 695          build_spec(multli, t_int, li_ddigit(ptr, 1));
mjsa 696      end if;
mjsa 697
mjsa 698
mjsa 699      end fnct multli;
       1 .=member uminli
       2      fnct uminli(arg1);
       3
       4$ this function accepts as its arguments any integer, short or long,
       5$ and returns the specifier it unary minus.
       6
       7      size uminli(hs);        $ integer specifier returned
       8
       9      size arg1(hs);          $ argument:  integer specifier
      10
      11      size copy1(hs);         $ general copy function
      12
      13
      14$ if the argument is a short integer then we can be sure that the unary
      15$ minus will fit into a one word long negative integer.  if the argument
      16$ is a long integer, we must check to see if it is a negative integer
      17$ whose negation may be represented as a short integer.
      18
      19      if otype_ arg1 = t_int then
      20
      21          if ivalue_ arg1 = 0 then
      22              uminli = zero;
      23          else
      24              build_lint1(uminli, ivalue_ arg1, negative);
      25          end if;
      26
      27      elseif otype_ arg1 = t_lint then
      28
      29          if li_snint(value_ arg1) then
      30              build_spec(uminli, t_int, li_ddigit(value_ arg1, 1));
      31          else
      32              uminli = copy1(arg1);
      33              li_sign(value_ uminli) = ^ li_sign(value_ uminli);
      34          end if;
      35
      36      else
      37          call err_type(13);
      38          uminli = err_val(f_int);
      39      end if;
      40
      41
      42      end fnct uminli;
       1 .=member equalli
       2      fnct equalli(arg1, arg2);
       3
       4$ this function returns a little boolean value of either yes or no
       5$ depending upon whether the two integer arguments are equal.
       6
       7      size equalli(1);        $ little boolean returned
       8
       9      size arg1(hs);          $ arguments are integer specifiers
      10      size arg2(hs);
      11
      12      size p1(ps);            $ pointers to lint data blocks
      13      size p2(ps);
      14      size j(ps);             $ loop index
      15
      16
      17      if (is_om_ arg1 ^= is_om_ arg2) go to fail;
      18      if (is_om_ arg1) go to pass;
      19
      20      if (eq(arg1, arg2)) go to pass;
      21      if (ne(arg1, arg2)) go to fail;
      22
      23$ if one integer is short and the other is long, then the two must be
      24$ distinct, since each integer has a unique representation.
      25
      26      if (otype_ arg1 ^= otype_ arg2) go to fail;
      27
      28$ in comparing two long integers for equality we first check the sign of
      29$ the two integers, then the number of digits in each, and finally
      30$ compare each of the corresponding digits.
      31
      32      p1 = value_ arg1;   p2 = value_ arg2;
      33
      34      if (li_sign(p1) ^= li_sign(p2)) go to fail;
      35      if (li_ndig(p1) ^= li_ndig(p2)) go to fail;
      36
      37      do j = 1 to li_ndig(p1);
      38          if (li_digit(p1, j) ^= li_digit(p2, j)) go to fail;
      39      end do;
      40
      41/pass/
      42      equalli = yes;
      43      return;
      44
      45/fail/
      46      equalli = no;
      47      return;
      48
      49
      50      end fnct equalli;
       1 .=member ltli
       2      fnct ltli(arg1, arg2);
       3
       4$ the function ltli returns true or false if the first argument is
       5$ less than the second.
       6
       7      size ltli(1);           $ little boolean value returned
       8
       9      size arg1(hs);          $ arguments are specifiers
      10      size arg2(hs);
      11
      12      size p1(hs);            $ pointers to argument blocks
      13      size p2(hs);
      14      size sign(1);           $ sign of arg1
      15      size i(ps);             $ loop index
      16
      17
      18      if otype_ arg1 = t_int & otype_ arg2 = t_int then
      19          ltli = (ivalue_ arg1 < ivalue_ arg2);
      20
      21      elseif otype_ arg1 = t_int & otype_ arg2 = t_lint then
      22          ltli = (li_sign(value_ arg2) = positive);
      23
      24      elseif otype_ arg1 = t_lint & otype_ arg2 = t_int then
      25          ltli = (li_sign(value_ arg1) = negative);
      26
      27      elseif otype_ arg1 = t_lint & otype_ arg2 = t_lint then
      28
      29          p1 = value_ arg1;
      30          p2 = value_ arg2;
      31
      32          if li_neg(p1) & li_pos(p2) then
      33              ltli = yes;
      34
      35          elseif li_pos(p1) & li_neg(p2) then
      36              ltli = no;
      37
      38          else    $ both long integers have same sign
      39              sign = li_sign(p1);
      40              if li_ndig(p1) < li_ndig(p2) then
      41                  ltli = (sign = positive);
      42              elseif li_ndig(p1) > li_ndig(p2) then
      43                  ltli = (sign = negative);
      44              else                     $ same sign and # digits
      45                  do i = li_ndig(p1) to 1 by -1;
      46                      if li_digit(p1, i) ^= li_digit(p2, i) then
      47                          ltli = ( (li_digit(p1, i) < li_digit(p2, i))
      48                                  = (sign = positive) );
      49                          return;
      50                      end if;
      51                  end do;
      52                  ltli = no;   $ numbers were equal
      53              end if;
      54          end if;
      55
      56      else
      57          call err_om(19);
      58      end if;
      59
      60
      61      end fnct ltli;
       1 .=member evenli
       2      fnct evenli(arg1);
       3
       4$ this function returns a little boolean value of true if the integer
       5$ argument is even.  this is accomplished by checking the last bit
       6$ of the integer.
       7
       8      size evenli(1);         $ specifier returned
       9
      10      size arg1(hs);          $ specifier for argument
      11
      12
      13      if otype_ arg1 = t_int then
      14          evenli = ((.f. 1, 1, ivalue_ arg1) = 0);
      15
      16      elseif otype_ arg1 = t_lint then
      17          evenli = ((.f. 1, 1, li_digit(value_ arg1, 1)) = 0);
      18
      19      else
      20          call err_type(13);
      21      end if;
      22
      23
      24      end fnct evenli;
       1 .=member floatli
       2      fnct floatli(arg1);
       3
       4$ this function returns a setl floating point representation for
       5$ a long integer argument.  since long integers have no limitations
       6$ on their size while reals do have some limits, it is possible
       7$ for an overflow to occur.
smfc  88$
smfc  89$ assert ws > real_mant_sz;
       8
       9      size floatli(hs);       $ real specifier returned
      10
      11      size arg1(hs);          $ integer specifier
      12
smfc  91      size j(ps);             $ loop index
smfc  92      size j1(ps);            $ index of long integer digit
smfc  93      size k1(ps);            $ number of bits in leading digit
smfc  94      size k2(ps);            $ index in value being assembled
smfc  95      size n(ps);             $ number of bits in long integer
smfc  96      size p1(ps);            $ pointer to long integer data block
smfc  97      size ptr(ps);           $ pointer to real data block
smfc  98
smfc  99      real r1;                $ real temporary
smfc 100
smfc 101      size val(ws);           $ signed integer temporary
smfc 102
smfc 103
smfc 104      if otype_ arg1 = t_lint then
smfc 105
smfc 106          p1 = value_ arg1;   $ pointer to long integer data block
smfc 107          j1 = li_ndig(p1);   $ number of digits in long integer
smfc 108          k1 = .fb. li_digit(p1, j1);  $ number of bits in leading digit
smfc 109          n  = (j1-1)*ds + k1;  $ number of bits in long integer
smfc 110
smfc 111          if n > real_mant_sz then
smfc 112              k2 = real_mant_sz - k1 + 1;
smfc 113          else
smfc 114              k2 = n - k1 + 1;
smfc 115          end if;
smfc 116
smfc 117          val = 0;
smfc 118
smfc 119          $ extract the leading min(real_mant_sz, n) bits from the long
smfc 120          $ integer.  this is done in three step, from left (high-order)
smfc 121          $ to right (low-order).
smfc 122
smfc 123          $ first extract all significant bits from the leading digit
smfc 124          .f. k2, k1, val = li_digit(p1, j1);
smfc 125
smfc 126          $ extract as many whole digits as required to fill the value
smfc 127          while k2 > ds;
smfc 128              k2 = k2 - ds; j1 = j1 - 1;
smfc 129              .f. k2, ds, val = li_digit(p1, j1);
smfc 130          end while;
smfc 131
smfc 132          $ extract the high-order bits of the next digit to fill the
smfc 133          $ remaining low-order bits of the value
smfc 134          if k2 > 1 then
smfc 135              .f. 1, k2-1, val =
smfc 136                  .f. (ds+1)-(k2-1), k2-1, li_digit(p1, j1-1);
smfc 137          end if;
smfc 138
smfc 139          if (li_neg(p1)) val = -val;
smfc 140
smfc 141          r1 = float(val);
smfc 142
smfc 143          $ do any required scaling
smfc 144          do j = real_mant_sz+1 to n by real_exp_base_sz;
smfc 145              r1 = r1 * real_exp_base;
smfc 146          end do;
smfc 147
smfc 148      elseif otype_ arg1 = t_int then
smfc 149          r1 = float(ivalue_ arg1);
smfc 150
smfc 151      else
smfc 152          if is_om_ arg1 then
smfc 153              call err_om(27);
smfc 154          else
smfc 155              call err_type(61);
smfc 156          end if;
smfc 157          floatli = err_val(f_real);
smfc 158          return;
smfd  49      end if;
smfc 160
smfd  50      get_real(ptr);   rval(ptr) = r1;
smfd  51      build_spec(floatli, t_real, ptr);
smfc 163
      74
      75      end fnct floatli;
       1 .=member fixli
       2      fnct fixli(arg1);
       3
       4$ functon fixli accepts as its argument the specifier for a setl real
       5$ number, and returns the long integer representation for that real
       6$ value, truncating any digits which are to the right of the decimal
       7$ point.
smfc 164$
smfc 165$ assert otype_ arg1 = t_real;
smfc 166$ assert ws > real_mant_sz & real_mant_sz > .fb. maxsi;
smfc 167
       8
       9      size fixli(hs);         $ integer specifier returned
      10
      11      size arg1(hs);          $ real specifier
      12
smfc 169      size j(ps);             $ loop index
smfc 170      size j1(ps);            $ index of long integer digit
smfc 171      size k1(ps);            $ number of bits in leading digit
smfc 172      size k2(ps);            $ index in value being assembled
smfc 173      size n(ps);             $ number of bits in long integer
smfc 174      size ptr(ps);           $ pointer to result long integer
smfc 175
smfc 176      real r1, r2;            $ real temporaries
smfc 177
smfc 178      size temp(ws);          $ field extract temporary
smfc 179      size val(ws);           $ signed integer temporary
smfc 180
smfc 181
smfc 182      r1 = rval(value_ arg1);
smfc 183      r2 = float(.f. 1, real_mant_sz, all_ones);
smfc 184
smfc 185      n = 0;
smfc 186
smfc 187      while abs(r1) > r2;
smfc 188          r1 = r1 / real_exp_base;   n = n + real_exp_base_sz;
smfc 189      end while;
smfc 190
smfc 191      val = ifix(r1);
smfc 192
smfc 193      if 0 <= val & val <= maxsi & n = 0 then
smfc 194          build_spec(fixli, t_int, val);
smfc 195
smfc 196      else
smfc 197
smfc 198          n  = n + .fb. iabs(val);  $ total size of result
smfc 199          j1 = (n+ds)/ds;     $ number of digits in result
smfc 200
smfc 201          $ allocate a j1-digit long integer and initialise it to zero
smfc 202          get_lint((j1+1)/2, ptr);
smfc 203          do j = hl_lint to li_nwords(ptr)-1; heap(ptr+j) = 0; end do;
smfc 204          li_sign(ptr) = (val < 0);   li_ndig(ptr) = j1;
smfc 205          build_spec(fixli, t_lint, ptr);
smfc 206
smfc 207          val = iabs(val);
smfc 208
smfc 209          k1 = mod(n, ds);    $ number of bits in leading digit
smfc 210          k2 = (.fb. val) - k1 + 1;  $ starting bit position in val
smfc 211
smfc 212          li_digit(ptr, j1) = .f. k2, k1, val;
smfc 213
smfc 214          while k2 > ds;
smfc 215              k2 = k2 - ds;   j1 = j1 - 1;
smfc 216              li_digit(ptr, j1) = .f. k2, ds, val;
smfc 217          end while;
smfc 218
smfc 219          if k2 > 1 then
smfc 220              temp = 0;
smfc 221              .f. (ds+1)-(k2-1), k2-1, temp = .f. 1, k2-1, val;
smfc 222              li_digit(ptr, j1-1) = temp;
smfc 223          end if;
smfd  52      end if;
     113
     114
     115      end fnct fixli;
       1 .=member hashli
       2      fnct hashli(arg1);
       3
       4$ this function returns the hash code for a long integer.  to calculate
       5$ the hash code we simply exclusive-oring each of the double digits of
       6$ the long integer and then fold the resulting word in two.  note: this
       7$ function may only be called with a long integer argument.
       8
       9      size hashli(hcsz);      $ hash code returned
      10
      11      size arg1(hs);          $ integer specifier
      12
      13      size temp(dds);         $ used in calc of hash code
      14      size p1(ps);            $ pointer to data block of arg1
      15      size i(ps);             $ loop index
      16
      17$ the hash code of a long integer is calculated by exclusive-oring each
      18$ of the double digits of the long integer, folding the result in two,
      19$ and then multiplying by the hash code seed.
      20
      21      p1 = value_ arg1;
      22      temp = 0;
      23
      24      do i = 1 to li_nddig(p1);
      25          temp = temp .ex. li_ddigit(p1, i);
      26      end do;
      27
      28      temp = (.f. 1, ds, temp)  .ex.  (.f. ds+1, ds, temp);
      29      hashli =  hcsd * (.f. 1, hcsz, temp);
      30
      31
      32      end fnct hashli;
       1 .=member valli
       2      fnct valli(arg1);
       3
       4$ the function valli takes as its argument a specifier for a string
       5$ which contains a sequence of numeric characters, and returns a
       6$ specifier to its integer representation.
       7
       8      size valli(hs);         $ integer specifier returned
       9
      10      size arg1(hs);          $ argument is string specifier
      11
      12      size ss(ssz);           $ string specifier to number string
      13      size ptr(hs);           $ pointer to data block of result
      14      size ndigs(ws);         $ number of li_dbas digits in value
      15      size sign(1);           $ sign of number
      16      size carry(ws);         $ carry for addition and multiplication
      17      size first_char(ws);    $ pointer to first digit in num string
      18      size last_char(ws);     $ pointer to last digit in num string
      19      size next_char(ws);     $ pointer to char being added to result
      20      size temp(ws);          $ temporary variable
      21      size i(ps);             $ loop index
      22      size j(ps);             $ loop index
asca  49      size c(cs);             $ current character
      23
      24      size trlint(hs);        $ function to transform short to long int
asca  50 .+ascebc size ebchar(cs);    $ ascii-to-ebcdic conversion function
      26
      27$ first we look at the number of characters in the string, then check to
      28$ see if the leading character is a "+" or a "-", and then reset the
      29$ number of characters and finally set the sign.
      30
      31      if is_om_ arg1 then
      32          call err_om(13);
      33          valli = err_val(f_int);
      34          return;
      35      end if;
stra 550
stra 551      if otype_ arg1 = t_string then  $ short character string
stra 552          if sc_nchars_ arg1 = 0 then  $ null string - this is an error
stra 553              valli = zero;  $ not diagnosed
stra 554          else
stra 555              c = scchar(arg1, 1);
stra 556 .+ascebc     if (ascebc_flag) c = ebchar(c);  $ convert to ebcdic
stra 557              c = c - 1r0;
stra 558              build_spec(valli, t_int, c);
stra 559          end if;
stra 560          return;
stra 561      end if;
      36
      37      ss = value_ arg1;
      38      sign = (icchar(ss, 1) = 1r-);
      39      first_char = 1 + sign;
      40      last_char = ss_len(ss);
      41      ndigs = li_dbas_digits(last_char) + 1;
      42
      43      $ initialise the result to zero
      44      get_lint(ndigs, ptr);
      45      do j = hl_lint to li_nwords(ptr);
      46          heap(ptr+j) = 0;
      47      end do;
      48      li_sign(ptr) = sign;
      49      li_ndig(ptr) = 1;
      50      build_spec(valli, t_lint, ptr);
      51
      52$ the strategy used to create an integer from a string is to use
      53$ horner's rule.  multiply the number by ten and then add the next digit
      54$ in line by the base of the number you are working in.  the first loop
      55$ performs the multiplication, while the second loop adds the next
      56$ digit.  in the second loop we only loop as long as there is a carry.
      57
      58      do i = first_char to last_char;
      59
      60          carry = 0;
      61          do j = 1 to li_ndig(ptr);
      62              temp = li_digit(ptr, j) * 10 + carry;
      63              carry = temp / li_bas;
      64              li_digit(ptr, j) = temp;
      65          end do;
      66
      67          if (carry) then
      68              li_ndig(ptr) = li_ndig(ptr) + 1;
      69              li_digit(ptr, li_ndig(ptr)) = carry;
      70          end if;
      71
asca  51          c = icchar(ss, i);
asca  52 .+ascebc if (ascebc_flag) c = ebchar(c);  $ convert to ebcdic
asca  53          carry = c - 1r0;
smff  10          do j = 1 to li_ndig(ptr);
smff  11              if (carry = 0) quit do j;
      75              temp = li_digit(ptr, j) + carry;
      76              carry = (temp >= li_bas);
      77              li_digit(ptr, j) = temp;
smff  12          end do j;
      80
      81          if (carry) then
      82              li_ndig(ptr) = li_ndig(ptr) + 1;
      83              li_digit(ptr, li_ndig(ptr)) = carry;
      84          end if;
      85
      86      end do;
      87
      88$ it is possible that the value of the string is a short integer,
      89$ so we must check for this case.
      90
      91      if li_spint(ptr) ! (li_ndig(ptr) = 1 & li_digit(ptr, 1) = 0) then
      92          build_spec(valli, t_int, li_ddigit(ptr, 1));
      93      end if;
      94
      95      end fnct valli;
       1 .=member strli
       2      fnct strli(arg1);
       3
       4$ the function strli accepts as its argument a specifier for an
       5$ integer and returns the specifier to the string version of
       6$ that integer.
       7
       8      size strli(hs);         $ string specifier returned
       9
      10      size arg1(hs);          $ long integer specifier
      11
      12      size ss(ssz);           $ pointer to string descriptor
      13      size a1(hs);            $ local copy of long int argument
      14      size p1(ps);            $ pointer to a1 data block
      15      size max_nchar(ps);     $ max no. of char in resulting str
      16      size sign_arg1(1);      $ need to save the sign of arg1
      17      size rem(ws);           $ remainder from divisions
      18      size temp(ws);          $ temporary result
      19      size next_char_pos(ps); $ counter into setl string
      20      size i(ps);             $ loop index
      21
      22      size nulllc(ssz);       $ returns null string specifier
      23      size trlint(hs);        $ converts short to long integer
      24      size copy1(hs);         $ copy utility
      25
      26$ setup a positive long integer value: if the number we are transforming
      27$ is a regular integer, we make a copy of it in long integer format.  if
      28$ it is a long integer, we make a copy.  in both cases we check and save
      29$ the sign of the number, and then change this copy to its absolute
      30$ value.
      31
      32      if type_ arg1 = t_int then
      33          a1 = trlint(arg1);
      34      else
      35          a1 = copy1(arg1);
      36      end if;
      37
      38      p1 = value_ a1;
      39
      40      sign_arg1 = li_sign(p1);
      41      li_sign(p1) = positive;
      42
      43$ we use the macro -li_decbas_digits- to estimate the number of
      44$ characters which will appear in the base ten representation of the
      45$ integer, and then call -nulllc- to allocate space for the string.
      46$ we set the -len- field to this number of characters so that we can
      47$ build the string from the back (least significant digits).
      48
      49      max_nchar =  li_decbas_digits(li_ndig(p1)) + sign_arg1;
      50      ss = nulllc(max_nchar);
      51      ss_len(ss) = max_nchar;
      52      next_char_pos = max_nchar;
      53
      54$ since we do not know exactly how many digits will be present in the
      55$ decimal representation of the li_bas number, we enter a while loop
      56$ which keeps the division going until a1 goes to zero.  instead of
      57$ keeping the result of each successive division in a seperate long
      58$ integer variable, we simply replace a1 during the division.  it should
      59$ also be noted that since we are not calling the regular division
      60$ routine in this situation, the value of a1 will reach a point in the
      61$ course of its successive divisions at which it could be represented as
      62$ a short integer.  we will not do this however, and instead make a
      63$ special check for zero.
      64
      65      until li_ndig(p1) = 1 & li_digit(p1, 1) = 0;
      66
      67          rem = 0;
      68          do i = li_ndig(p1) to 1 by -1;
      69              temp = rem * li_bas + li_digit(p1, i);
      70              li_digit(p1, i) = temp / 10;
      71              rem = mod(temp, 10);
      72          end do;
      73
      74          $ normalize a1
      75          while li_ndig(p1) > 1;
      76              if (li_digit(p1, li_ndig(p1)) ^= 0) quit while;
      77              li_ndig(p1) = li_ndig(p1) - 1;
      78          end while;
      79
      80          $ place the character in the string
      81          icchar(ss, next_char_pos) = 1r0 + rem;
      82          next_char_pos = next_char_pos - 1;
      83
      84      end until;
      85
      86$ we now must add the character "-" to the string if the number was
      87$ negative, and set the both the offset and length fields so that
      88$ so that they correctly reflect the position of the string within
      89$ the long string data block.
      90
      91      if sign_arg1 = negative then
      92          icchar(ss, next_char_pos) = 1r-;
      93          next_char_pos = next_char_pos - 1;
      94      end if;
      95
      96      ss_len(ss) = max_nchar - next_char_pos;
      97      ss_ofs(ss) = next_char_pos;
asca  54 .+ascebc if (ascebc_flag) call ascstr(ss);  $ convert to ascii
      99      build_spec(strli, t_istring, ss);
     100
     101
     102      end fnct strli;
       1 .=member putbli
       2      fnct putbli(id, arg1);
       3
       4$ this function performs the setl input/output operation -putb-
       5$ for long integers.
       6
       7      size putbli(hs);        $ om is returned
       8
       9      size id(ps);            $ little file id
      10      size arg1(hs);          $ long integer specifier to be written
      11
      12      size p1(ps);            $ pointer to data block for arg1
      13      size putbhdrblk(hs);    $ header block for binary output
      14      size len(ws);
      15
      16$ define these local macros so that they are precisely the same
      17$ as those defined in the binary input/output package.
      18
      19      +* putbhdr(t, v) =
      20          putbhdrblk = 0;
      21          bh_typ_ putbhdrblk = t;
      22          bh_val_ putbhdrblk = v;
      23          write id, putbhdrblk;
      24          **
      25
      26      +* putbdatn(p, n) =
      27          write id, heap(p) to heap(p+(n)-1);
      28          **
      29
      30
      31$ we first calculate the number of words which need to be writen to the
      32$ file, and then create the header and data blocks using the above
      33$ macros.  notice that we do not copy all of the words which compose
      34$ this particular form of the integer, since it is possible that more
      35$ blocks were allocated for the integer than were necessary.  we instead
      36$ look at the number of double digits (li_dbas digits) in the number,
      37$ an only write this necessary number to file -id-.  this is important
      38$ since the li_ndig field is not stored in the binary representation, so
      39$ we must be sure that all of the stored words represent valid data.
      40
      41      p1 = value_ arg1;
      42      len = li_nddig(p1);
      43
      44      putbhdr(bt_int, len);
      45      putbdatn(p1 + hl_lint, len);
      46
      47      putbli = spec_om;
      48
      49$ drop the local macros.
      50
      51      macdrop2(putbhdr, putbdatn);
      52
      53      end fnct putbli;
       1 .=member getbli
       2      fnct getbli(id, val);
       3
       4$ this function performs the setl input/output operation -getb-
       5$ for long integers.  it returns the specifier to the integer
       6$ which it has just read in.
       7
       8      size getbli(hs);        $ specifier returned
       9
      10      size id(ps);            $ little file id
      11      size val(hs);           $ number words read in
      12
      13      size ptr(ps);           $ pointer to resulting data block
      14      size getbword(hs);      $ most recently read data word from id
      15
      16$ by looking at the val field we can tell if there is a possibility that
      17$ the integer which we are reading is actually a short integer value.
      18$ it may however be a long integer value (a positive number which fits
      19$ into a setl word)
      20
      21      if val = 1 then
      22
      23          read id ,getbword;
      24
smfc 225          if 0 <= getbword & getbword <= maxsi then
      26              build_spec(getbli, t_int, getbword);
      27          else
      28              get_lint1(ptr); build_spec(getbli, t_lint, ptr);
      29              heap(ptr + hl_lint) = getbword;
      30              li_ndig(ptr) = 1 + (li_ddigit(ptr, 1) >= li_bas);
      31          end if;
      32
      33$ if the value of val is greater than one, then we can be sure that we
      34$ have a long integer.
      35
      36      else
      37          get_lint(val, ptr); build_spec(getbli, t_lint, ptr);
      38
      39          read id ,heap(ptr+hl_lint) to heap(ptr+hl_lint+val-1);
      40
      41          li_ndig(ptr) =
      42              (2 * (val-1)) + 1 + (li_ddigit(ptr, val) >= li_bas);
      43      end if;
      44
      45
      46      end fnct getbli;
       1 .=member putintli
       2      fnct putintli(val);
       3
       4$ this function receives as an argument a little signed integer and
       5$ returns a specifier to the setl representation of that integer.
       6
       7      size putintli(hs);      $ integer specifier returned
       8
       9      size val(ws);           $ little signed integer
      10
      11      size ptr(hs);
      12
      13
      14$ in order to represent the argument as a setl integer, we must be able
      15$ to take its absolute value.  in the case of a one's complement machine
      16$ this never presents a problem since each negative number may be
      17$ represented as positive number (the largest negative number requires
      18$ the same number of bits as the largest positive number).  in the case
      19$ of a two's complement machine, however, the absolute value of the
      20$ largest negative number will not fit into a machine word.  since the
      21$ largest negative number is used for the special value -om_int- on
      22$ two's complement machines, this does not cause a problem.  normally,
      23$ this routine is called from within the -put_intval- macro, and hence
      24$ -val- will never be -om_int- or in the range [ 0..maxsi ].  there is
      25$ one exception:  when we initialise the sample values, we call this
      26$ routine directly with val = om_int.  all that matters in that context
      27$ is that we return an omega-long-integer specifier.
      28
      29      if val = om_int then
      30          get_lint1(ptr); build_spec(putintli, t_olint, ptr);
      31          li_ddigit(ptr, 1) = 0;
      32          li_sign(ptr) = positive;
      33          li_ndig(ptr) = 0;
      34
      35      elseif 0 <= val & val <= maxsi then
      36          call err_misc(47);
      37
      38      elseif iabs(val) < li_dbas then
      39          build_lint1(putintli, iabs(val), (val < 0));
      40
      41      else
      42          get_lint(2, ptr); build_spec(putintli, t_lint, ptr);
      43
      44          li_ddigit(ptr, 1) = .f.     1,      dds, iabs(val);
      45          li_ddigit(ptr, 2) = .f. dds+1, ws-dds-1, iabs(val);
      46          li_sign(ptr) = (val < 0);
      47          li_ndig(ptr) = 3;
      48      end if;
      49
      50
      51      end fnct putintli;
       1 .=member getintli
       2      fnct getintli(spec);
       3
       4$ this function gets as an argument a setl integer and returns
       5$ a little signed integer when possible.
       6
       7      size getintli(ws);      $ little signed integer returned
       8
       9      size spec(hs);          $ setl integer specifier
      10
      11      size p1(ps);
      12
      13
      14$ if we have a short integer argument then the value resides in the
      15$ value field of the specifier.  if we have a long integer, then we
      16$ must check that we are able to put the value into a machine word.
      17
      18      if otype_ spec = t_int then
      19          getintli = ivalue_ spec;
      20
      21$ long integers can be divided into three categories:  1) those with
      22$ less than two li_bas digits may always be transformed, 2) those
      23$ with three digits may sometimes be transformed and the tranformation
      24$ will depend upon whether the machine is two's or one's complement
      25$ if the number is negative, 3) those with greater than three digits may
      26$ never be transformed since their magnitude is too great to fit into
      27$ a machine word.
      28
      29      elseif otype_ spec = t_lint then
      30
      31          p1 = value_ spec;
      32
      33          if li_ndig(p1) <= 2 then        $ must be in range
      34
      35              getintli = li_ddigit(p1, 1);
      36              if (li_neg(p1)) getintli = -getintli;
      37
      38$ because li_dbas has only one less bit than the number of bits used to
      39$ represent the magnitude of a machine integer, the only possible value
      40$ for the third digit is one.  otherwise the number will be out of
      41$ range.
      42
      43          elseif li_nddig(p1) = 2 then
      44
      45              if .fb. li_ddigit(p1, 2) < ws-dds then
      46                  getintli = li_ddigit(p1, 1);
      47                  .f. dds+1, ws-dds-1, getintli = li_ddigit(p1, 2);
      48                  if (li_neg(p1)) getintli = -getintli;
      49              else
      50                  call err_misc(21);      $ number out of range
      51              end if;
      52          else
      53              call err_misc(21);
      54          end if;
      55      else
      56          call err_om(13);         $ omega value
      57      end if;
      58
      59      end fnct getintli;
       1 .=member intad1
       2$ internal arithmetic routines used by lint interface routines.
       3$ -------- ---------- -------- ---- -- ---- --------- ---------
       4
       5
       6      fnct intad1(arg1, arg2, sign);
       7
       8$ this function adds the absolute values of two integers, the first
       9$ of which is a long integer, and the second of which is a short
      10$ integer.  although -arg1- may actually be negative, we take look
      11$ only at the magnitude of the number and add this to -arg2-.
      12
      13      size intad1(hs);        $ result is a specifier
      14
      15      size arg1(hs);          $ long integer specifier
      16      size arg2(hs);          $ short integer specifier
      17      size sign(1);           $ result should have this sign
      18
      19      size ptr(hs);           $ pointer to long int data block
      20      size p1(ps);            $ pointer to long int data block
      21      size temp(ws);          $ used to store partial sums
      22      size carry(1);          $ carry
      23      size j(ps);             $ loop index
      24
      25$ allocate space for result:  the result can have at most 1 more digit
      26$ than the long integer argument.  we know that the result must be a
      27$ long integer value, so we build the specifier now.
      28
      29      p1 = value_ arg1;
      30
      31      get_lint(li_nddig(p1) + 1, ptr);
      32      build_spec(intad1, t_lint, ptr);
      33
      34$ set the pointer to the data block of the long integer argument, and
      35$ then begin the addition, adding the first digit, and then adding the
      36$ carry as long as necessary.
      37
      38      temp = li_ddigit(p1, 1) + ivalue_ arg2;
      39      carry = (temp >= li_dbas);
      40      li_ddigit(ptr, 1) = temp;
      41
      42      do j = 2 to li_nddig(p1);
      43          temp = li_ddigit(p1, j) + carry;
      44          carry = (temp >= li_dbas);
      45          li_ddigit(ptr, j) = temp;
      46      end do;
      47
      48$ set number of digits, the sign, and zero an odd leading integer:
      49
      50      if li_oddndig(p1) then
      51          $ assert carry = 0;
      52          li_ndig(ptr) = li_ndig(p1) + (temp >= li_bas);
      53      elseif (carry) then
      54          li_digit(ptr, li_ndig(p1) + 1) = 1;
      55          li_ndig(ptr) = li_ndig(p1) + 1;
      56      else
      57          li_ndig(ptr) = li_ndig(p1);
      58      end if;
      59      li_sign(ptr) = sign;
      60      if (li_oddndig(ptr)) li_digit(ptr, li_ndig(ptr)+1) = 0;
      61
      62$ in the course of the addition it is possible that value became small
      63$ enough to be represented as a short integer.  check for this case.
      64
      65      if li_spint(ptr) ! (li_ndig(ptr) = 1 & li_digit(ptr, 1) = 0) then
      66          build_spec(intad1, t_int, li_ddigit(ptr, 1));
      67      end if;
      68
      69      end fnct intad1;
       1 .=member intad2
       2      fnct intad2(arg1, arg2, sign);
       3
       4$ this function adds two long integers and returns a specifer to the
       5$ result with a sign equal to that of the parameter -sign-.
       6
       7      size intad2(hs);        $ integer specifier returned
       8
       9      size arg1(hs);          $ input specifiers
      10      size arg2(hs);
      11      size sign(1);           $ returned integer must have this sign
      12
      13      size p1(ps);            $ pointers to long integer data blocks
      14      size p2(ps);
      15      size ptr(ps);
      16      size temp(ws);          $ holds the temporary result of additions
      17      size g(ps);             $ pointer to lint with greater # of digits
      18      size l(ps);             $ pointer to lint with lesser # of digits
      19      size gdigs(ws);         $ greater number of digits
      20      size ldigs(ws);         $ lesser number of digits
      21      size i(ps);             $ loop index
      22      size carry(1);          $ carry
      23
      24$ after setting pointers to the data blocks of the two long
      25$ integers, we check to see which has the greater number of
      26$ double digits, and then set the values of g, l, gdigs, ldigs
      27$ accordingly.  we also allocate heap space for the result.
      28
      29      p1 = value_ arg1;
      30      p2 = value_ arg2;
      31
      32      if li_ndig(p1) >= li_ndig(p2) then
      33          g = p1;
      34          l = p2;
      35      else
      36          g = p2;
      37          l = p1;
      38      end if;
      39
      40      gdigs = li_nddig(g);
      41      ldigs = li_nddig(l);
      42
      43      get_lint(gdigs + 1, ptr);
      44      build_spec(intad2, t_lint, ptr)
      45
      46$ first part of the addition:  we add the digits of the two long
      47$ integers up to the most significant digit of the smaller
      48$ of the two integers.
      49
      50      carry = 0;
      51      do i = 1 to ldigs;
      52          temp = li_ddigit(g, i) + li_ddigit(l, i) + carry;
      53          carry = (temp >= li_dbas);
      54          li_ddigit(ptr, i) = temp;
      55      end do;
      56
      57      do i = ldigs + 1 to gdigs;
      58          temp = li_ddigit(g, i) + carry;
      59          carry = (temp >= li_dbas);
      60          li_ddigit(ptr, i) = temp;
      61      end do;
      62
      63$ set the number of digits, the sign, and zero any odd leading digits:
      64$ if the carry is now 1, we must add one more digit.
      65$ also, set the sign of the answer to the sign of p1, since
      66$ both long integers were assumed to have the same sign.
      67
      68      if (carry) then
      69          li_ddigit(ptr, gdigs + 1) = carry;
      70          li_ndig(ptr) = 2 * gdigs + 1;
      71      else
      72          li_ndig(ptr) = 2 * (gdigs - 1) + 1 +  (temp >= li_bas);
      73      end if;
      74
      75      li_sign(ptr) = sign;
      77
      78$ if we were adding two short negative integers, it is possible that the
      79$ result is a short integer.
      80
      81      if li_spint(ptr) ! (li_ndig(ptr) = 1 & li_digit(ptr, 1) = 0) then
      82          build_spec(intad2, t_int, li_ddigit(ptr, 1));
      83      end if;
      84
      85
      86      end fnct intad2;
       1 .=member intsb1
       2      fnct intsb1(arg1, arg2, sign);
       3
       4$ this function subtracts the short integer arg2 from the absolute value
       5$ of a long integer.  we do not actually compute the absolute value of
       6$ the long integer but instead take advantage of the signed-magnitude
       7$ representation of long integers.  the parameter -sign- gives the sign
       8$ of the result.
       9
      10      size intsb1(hs);        $ result is a specifier
      11
      12      size arg1(hs);          $ long integer specifier
      13      size arg2(hs);          $ short integer specifier
      14      size sign(1);           $ sign of the result
      15
      16      size ptr(ps);           $ pointer to data block of result
      17      size p1(ps);            $ pointer to long int data block
      18      size temp(ws);          $ temporary result for difference
      19      size borrow(1);         $ borrow
      20      size j(ps);             $ loop index
      21
      22$ allocate space for the result:  the largest possible number of digits
      23$ in the result could be the same as the number of digits in -arg1-.
      24
      25      p1 = value_ arg1;
      26
      27      get_lint(li_nddig(p1), ptr);
      28      build_spec(intsb1, t_lint, ptr);
      29
      30$ subtract the short integer from the least significant digit of the
      31$ long integer.  then complete the subtraction taking into account that
      32$ the carry may affect even the most significant digit.
      33
smfc 226      do j = hl_lint to li_nwords(ptr)-1;
      35          heap(ptr+j) = 0;
      36      end do;
      37
      38      temp = li_ddigit(p1, 1) - ivalue_ arg2;
      39      borrow = (temp < 0);
      40      if (borrow) temp = temp + li_dbas;
      41      li_ddigit(ptr, 1) = temp;
      42
      43      do j = 2 to li_nddig(p1);
      44          temp = li_ddigit(p1, j) - borrow;
      45          borrow = (temp < 0);
      46          if (borrow) temp = temp + li_dbas;
      47          li_ddigit(ptr, j) = temp;
      48      end do;
      49
      50      li_ndig(ptr) = li_ndig(p1);
      51      while li_ndig(ptr) > 1;
      52          if (li_digit(ptr, li_ndig(ptr)) > 0) quit while;
      53          li_ndig(ptr) = li_ndig(ptr) - 1;
      54      end while;
      55
      56      li_sign(ptr) = sign;
      57
      58$ note that if there is an odd, leading digit, it must be zero.  next
      59$ check whether the result can be represented as a short integer.
      60
      61      if li_spint(ptr) ! (li_ndig(ptr) = 1 & li_digit(ptr, 1) = 0) then
      62          build_spec(intsb1, t_int, li_ddigit(ptr, 1));
      63      end if;
      64
      65      end fnct intsb1;
       1 .=member intsb2
       2      fnct intsb2(arg1, arg2, sign);
       3
       4$ this function subtracts one long integer from another and returns the
       5$ specifier for the result, which can be either a short or a long
       6$ integer.
       7
       8      size intsb2(hs);        $ integer specifier returned
       9
      10      size arg1(hs);          $ arguments are specifiers
      11      size arg2(hs);
      12      size sign(1);           $ returned value must have this sign
      13
      14      size p1(ps);            $ pointers to data blocks
      15      size p2(ps);
      16      size ptr(ps);
      17      size gdigs(ws);         $ number of li_dbas digits in larger int
      18      size ldigs(ws);         $ number of li_dbas digits in smaller int
      19      size borrow(ws);        $ borrow from partial subtractions
      20      size temp(ws);          $ temporary values
      21      size i(ps);             $ loop index
      22      size j(ps);             $ loop index
      23
      24$ set the pointers to the data block of the long integers, and then
      25$ allocate space in the heap for the result.
      26
      27      p1 = value_ arg1;
      28      p2 = value_ arg2;
      29
      30      gdigs = li_nddig(p1);
      31      ldigs = li_nddig(p2);
      32
      33      get_lint(gdigs, ptr);
      34      build_spec(intsb2, t_lint, ptr);
      35
      36$ start by subtracting the as many digits as are present in the smaller
      37$ number.  then finish the subtraction by carrying along the borrow.
      38
smfc 227      do j = hl_lint to li_nwords(ptr)-1;
      40          heap(ptr+j) = 0;
      41      end do;
      42
      43      borrow = 0;
      44      do i = 1 to ldigs;
      45          temp = li_ddigit(p1, i) - li_ddigit(p2, i) - borrow;
      46          borrow = (temp < 0);
      47          if (borrow) temp = temp + li_dbas;
      48          li_ddigit(ptr, i) = temp;
      49      end do;
      50
      51      do i = ldigs + 1 to gdigs;
      52          temp = li_ddigit(p1, i) - borrow;
      53          borrow = (temp < 0);
      54          if (borrow) temp = temp + li_dbas;
      55          li_ddigit(ptr, i) = temp;
      56      end do;
      57
      58$ if a final carry took place then it is possible that the leading
      59$ digit became a zero.  in this case we must normalize the long integer.
      60
      61      li_ndig(ptr) = li_ndig(p1);
      62      while li_ndig(ptr) > 1;
      63          if (li_digit(ptr, li_ndig(ptr)) > 0) quit while;
      64          li_ndig(ptr) = li_ndig(ptr) - 1;
      65      end while;
      66
      67      li_sign(ptr) = sign;
      69
      70$ check to see that the value generated by the subtraction can be
      71$ represented as a short integer.
      72
      73      if li_spint(ptr) ! (li_ndig(ptr) = 1 & li_digit(ptr, 1) = 0) then
      74          build_spec(intsb2, t_int, li_ddigit(ptr, 1));
      75      end if;
      76
      77      end fnct intsb2;
       1 .=member intdiv
       2      fnct intdiv(arg1, arg2, op);
       3
       4$ this function divides two integers in long integer format.  if one of
       5$ the two arguments can be represented as a short integer, it must be
       6$ transformed into a long integer format in order to use this routine.
       7$ the parameter op determines whether the value returned by this
       8$ function is the quotient (op=1) or the mod (op=2).
       9
      10      size intdiv(hs);        $ integer specifier returned
      11
      12      size arg1(hs);          $ long integer specifiers
      13      size arg2(hs);
      14      size op(ws);
      15
      16      size a1(hs);            $ local copy of arg1
      17      size a2(hs);            $ local copy of arg2
      18      size p1(ps);            $ pointer to data block of arg1
      19      size p2(ps);            $ pointer to data block of arg2
      20      size ptr(ps);           $ pointer to data block of intdiv
      21      size sign(1);           $ sign of the result
      22      size scale(ws);         $ scaling factor for case 4
      23      size temp(ws);          $ temporary result
      24      size rr(ws);            $ remainder of division steps
      25      size divisor(ws);       $ divisor in case three
      26      size c(ws);             $ carry
      27      size qe(ws);            $ quotient estimate
      28      size du(ws);            $ temporary variable
      29      size temp2(ws);         $ temporary variable
      30      size m(ps);             $ number of digits in dividend minus n
      31      size n(ps);             $ number of digits in divisor
      32      size i(ps);             $ loop index
      33      size j(ps);             $ loop index
      34      size k(ps);             $ loop index
      35
      36      size copy1(hs);         $ copy function
      37      size addli(hs);         $ arithmetic functions used
      38      size diffli(hs);
      39      size equalli(hs);
      40
      41$ on entering this function we assume only that both the divisor and the
      42$ dividend are in long integer format.  we divide the function into four
      43$ cases:  1) division by zero;  2) fewer digits in the dividend than the
      44$ divisor;  3) a divisor with only one digit;  4) a divison with a
      45$ multi-digit divisor.
      46
      47$ case one: division by zero.  if the divisor is equal to zero then we
      48$ must call an error.
      49
      50      if eq(arg2, zero) then
      51
      52          call err_type(0);
      53          return;
      54
      55$ case two: fewer digits in dividend than divisor. in the case where
      56$ there are fewer digits in the divisor than the dividend we can be
      57$ certain that the result is zero.  if the dividend is negative we must
      58$ add the divisor to it to get the mod
      59
      60      elseif li_ndig(value_ arg1) < li_ndig(value_ arg2) then
      61
      62          if op = 1 then
      63              intdiv = zero;
      64          else
      65              if li_pos(value_ arg1) then
      66                  intdiv = copy1(arg1);
      67              elseif li_pos(value_ arg2) then
      68                  intdiv = addli(arg1, arg2);
      69              else    $ arg2 is negative:  subtract instead
      70                  intdiv = diffli(arg1, arg2);
      71              end if;
      72          end if;
      73
      74          return;
      75
      76$ case three: one digit divisor. we now further subdivide the case of a
      77$ division into the cases of a one digit divisor, and a multi digit
      78$ divisor.  we do this not only because it is more efficient, but also
      79$ because the quotient estimation algorithm used in the latter case
      80$ assumes at least two digits in the divisor. it is also worth noting
      81$ that -p1- begins by pointing to a copy of the dividend but after the
      82$ division points to the quotient.  it is possible that in the course of
      83$ doing the division we will reduce the magnitude of the first argument
      84$ to the extent that the result can be represented as a short integer.
      85
      86      elseif li_ndig(value_ arg2) = 1 then
      87
      88          a1 = copy1(arg1);
      89          ptr = value_ a1;
      90
      91          rr = 0;
      92          divisor = li_digit(value_ arg2, 1);
      93          do j = li_ndig(ptr) to 1 by -1;
      94              temp = rr * li_bas + li_digit(ptr, j);
      95              li_digit(ptr, j) = temp / divisor;
      96              rr = mod(temp, divisor);
      97          end do;
      98
      99          if op = 1 then
     100
     101              if li_digit(ptr, li_ndig(ptr)) = 0 then
     102                  li_ndig(ptr) = li_ndig(ptr) - 1;
     103              end if;
     104              build_spec(intdiv, t_lint, ptr);
     105              li_sign(ptr) = (li_sign(ptr) ^= li_sign(value_ arg2));
     108
     109              if li_ndig(ptr) <= 1 & li_digit(ptr, 1) = 0 then
     110                  intdiv = zero;
     111              elseif li_spint(ptr) then
     112                  build_spec(intdiv, t_int, li_ddigit(ptr, 1));
     113              end if;
     114
     115          else    $ op = 2:  compute remainder
     117              if (li_neg(value_ arg1) & rr ^= 0) rr = divisor - rr;
     118
     119              if rr <= maxsi then
     120                  build_spec(intdiv, t_int, rr);
     121              else
     122                  build_lint1(intdiv, rr, positive);
     123              end if;
     124          end if;
     125
     126          return;
     127
     128$ case four: divisor has at least two digits.  we have the case of a
     129$ long integer with several digits being divided by a long integer with
     130$ at least two digits.  we begin by making copys of the two integers
     131$ being divided. the dividend must be padded with one extra zero, so we
     132$ must copy it without the help of the function -copy1-. we then set the
     133$ pointers p1 and p2 to point to the copies of the two arguments.  we
     134$ must also create a special long integer block for the result, whose
     135$ value has been initialized to zero and whose number of digits field
     136$ states that it contains m + 1 digits.
     137
     138      elseif li_ndig(value_ arg2) > 1 then
     139
     140          $ make copies of both arguments:
     141          m = li_ndig(value_ arg1) - li_ndig(value_ arg2);
     142          n = li_ndig(value_ arg2);
     143          sign = (li_sign(value_ arg1) ^= li_sign(value_ arg2));
     144
     145          $ copy arg1 padding it with an extra zero at the left
     146          get_lint(li_nddig(value_ arg1) + 1, p1);
     147          do i = 1 to li_ndig(value_ arg1);
     148              li_digit(p1, i) = li_digit(value_ arg1, i);
     149          end do;
     150          li_digit(p1, li_ndig(value_ arg1) + 1) = 0;
     151          li_sign(p1) = li_sign(value_ arg1);
     152          li_ndig(p1) = li_ndig(value_ arg1) + 1;
     153
     154          $ copy arg2
     155          a2 = copy1(arg2);
     156          p2 = value_ a2;
     157
     158          $ allocate space for the quotient
     159          get_lint(((m + 1) + 1) / 2, ptr);
smfc 228          do j = hl_lint to li_nwords(ptr)-1;
     161              heap(ptr+j) = 0;
     162          end do;
     163          li_sign(ptr) = sign;
     164          li_ndig(ptr) = m + 1;
     165
     166$ multiply both arguments by scaling factor since the division algorithm
     167$ requires the divisor be >= li_bas.
     168
     169          scale = li_bas / (li_pdigit(p2, 1) + 1);
     170          if scale ^= 1 then
     171              c = 0;
     172              do i = 1 to li_ndig(p1);
     173                  temp = li_digit(p1, i) * scale + c;
     174                  li_digit(p1, i) = temp;
     175                  c = temp / li_bas;
     176              end do;
     177              c = 0;
     178              do i = 1 to li_ndig(p2);
     179                  temp = li_digit(p2, i) * scale + c;
     180                  li_digit(p2, i) = temp;
     181                  c = temp / li_bas;
     182              end do;
     183          end if;
     184
     185$ now we come to the main loop of the algorithm.  this loop has five
     186$ parts:  1) estimate the quotient;  2) refine the estimate 3) subtract
     187$ qe times the divisor from the dividend; 4) add back the divisor if the
     188$ estimate was too high, and 5) set the the digit to the estimate.
     189
     190          do j = 1 to (m + 1);
     191
     192              $ part one: estimate qe.
     193              if li_pdigit(p1, j) ^= li_pdigit(p2, 1) then
     194                  qe = (li_pdigit(p1, j) * li_bas + li_pdigit(p1, j+1))
     195                          / li_pdigit(p2, 1);
     196              else
     197                  qe = li_bas - 1;
     198              end if;
     199
     200              $ part two:  refine estimate of qe.
     201              while qe * li_pdigit(p2, 2) >
     202                     ( (li_pdigit(p1, j) * li_bas + li_pdigit(p1, j+1))
     203                       - qe * li_pdigit(p2, 1) ) * li_bas
     204                         + li_pdigit(p1, j+2);
     205                 qe = qe - 1;
     206              end while;
     207
     208              $ part three:  subtract qe times the divisor from the
     209              $ dividend.
     210              c = 0;
     211              do k = n to 1 by -1;
     212                  du = li_pdigit(p1,j+k) - (qe * li_pdigit(p2,k)) + c;
     213                  temp = du - ((du / li_bas) * li_bas);
     214                  c = du / li_bas;
     215                  if temp < 0 then
     216                      li_pdigit(p1, j+k) = temp + li_bas;
     217                      c = c - 1;
     218                  else
     219                      li_pdigit(p1, j+k) = temp;
     220                  end if;
     221              end do;
     222
     223              $ part four:  if temp is negative, then qe was high and we
     224              $ must add back the divisor and adjust qe.
     225              temp = li_pdigit(p1, j) + c;
     226              if temp < 0 then
     227                  qe = qe - 1;
     228                  c = 0;
     229                  do k = n to 1 by -1;
     230                      temp2 = li_pdigit(p1,j+k) + li_pdigit(p2,k) + c;
     231                      c = (temp2 >= li_bas);
     232                      li_pdigit(p1, j+k) = temp2;
     233                  end do;
     234                  li_pdigit(p1, j) = temp + c;
     235              else
     236                  li_pdigit(p1, j) = temp;
     237              end if;
     238
     239              $ part five: set the j-th digit of result to qe.
     240              li_pdigit(ptr, j) = qe;
     241
     242          end do j;
     243
     244$ although we have finished the division, we must check to see whether
     245$ this routine was called for the purpose of doing a division, or to
     246$ find the mod of two numbers.  if it was called to find the division
     247$ nothing much needs to be done.  if it was called in order to calculate
     248$ the mod, we must reset the pointer -ptr- to point to -p1- and then
     249$ divide the remainder by the scaling factor.
     250
     251          if op = 2 then  $ compute remainder
     252
     253              ptr = p1;       $ change the result to the remainder
     254              sign = li_sign(p1);
     255
     256              if scale ^= 1 then
     257                  rr = 0;
     258                  do j = 1 to li_ndig(ptr);
     259                      temp = rr * li_bas + li_pdigit(ptr, j);
     260                      li_pdigit(ptr, j) = temp / scale;
     261                      rr = mod(temp, scale);
     262                  end do;
     263              end if;
     264          end if;
     265
     266          $ normalize the result
     267          while li_ndig(ptr) > 1;
     268              if (li_digit(ptr, li_ndig(ptr)) > 0) quit while;
     269              li_ndig(ptr) = li_ndig(ptr) - 1;
     270          end while;
     271
     272          li_sign(ptr) = sign;
     274
     275          build_spec(intdiv, t_lint, ptr);
     276
     277          $ check if result can be represented as a short int
     278          if li_spint(ptr) ! (li_ndig(ptr)=1 & li_digit(ptr,1)=0) then
     279              build_spec(intdiv, t_int, li_ddigit(ptr, 1));
     280
     281          elseif li_neg(ptr) & op = 2 then  $ increment neg remainder
     282              if li_pos(value_ arg2) then
     283                  intdiv = addli(intdiv, arg2);
     284              else    $ arg2 is negative:  subtract instead
     285                  intdiv = diffli(intdiv, arg2);
     286              end if;
     287          end if;
     288
     289$ otherwise, one of the arguments was undefined, so we print an
     290$ error message.
     291
     292      else
     293          call err_type(13);
     294          intdiv = err_val(f_int);
     295      end if;
     296
     297      end fnct intdiv;
       1 .=member trlint
       2      fnct trlint(arg1);
       3
       4$ the function trlint transforms a setl short integer into it's setl
       5$ long integer format.  this form of integer exists only within the
       6$ package for the sake of certain routines (e.g., multiplication)
       7$ which are simplified by the use of such a representation.
       8
       9      size trlint(hs);
      10
      11      size arg1(hs);
      12
      13$ we simply build a long integer whose value happens to fall below
      14$ maxsi.
      15
      16      build_lint1(trlint, ivalue_ arg1, positive);
      17
      18      end fnct trlint;
       1 .=member umin
       2      fnct umin(arg);
       3
       4$ unary minus operator
       5
       6
       7      size arg(hs);   $ specifier for long or short integer
       8
       9      size umin(hs);  $ value returned
      10
      11      size val(hs),           $ integer value of -arg-
      12           temp(hs);          $ temporary value
      13
      14      real v;                 $ real value of -arg-
mjsa 700
mjsa 701      size uminli(hs);        $ returns complement of integers
      15
      16
      17      if otype_ arg = t_real then
      18          v    = rval(value_ arg);
      19          v    = - v;
      20          temp = v;
      21          put_realval(temp, umin);
      22
      23      else
mjsa 702          umin = uminli(arg);
      27      end if;
      28
      29
      30      end fnct umin;
       1 .=member sabs
       2      fnct sabs(arg);
       3
       4$ this is the setl -abs x- routine.  for a numeric x, it returns the
       5$ absolute value of the argument;  for a character string of length
       6$ one, it returns an integer whose value is the internal representation
       7$ of the string character.
       8
       9
      10      size arg(hs);           $ specifier for argument
      11
      12      size sabs(hs);          $ specifier returned
      13
      14      size a(hs);             $ local copy of argument
      15      size p(ps);             $ pointer to long int
      16      size v(hs);             $ integer value
      17      size ss(ssz);           $ string specifier
      18
      19      real r;                 $ real temporary
mjsa 703
mjsa 704      size ltli(1);
mjsa 705      size uminli(hs);
      20
      21
      22      a = arg;
      23
      24/switch/
      25
      26      go to case(otype_ a) in t_min to t_max;
      27
      28
      29/case(t_int)/                 $ short integer
      30
      31      sabs = a;               $ short integers are always positive
      32      return;
      33
      34
      35/case(t_string)/              $ short character string
stra 562
stra 563      if (sc_nchars_ a ^= 1) go to error2;
stra 564
stra 565      v = scchar(a, 1);
stra 566      build_spec(sabs, t_int, v);
stra 567
stra 568      return;
stra 569
      36
      37/case(t_atom)/                $ short atom
      38
      39/case(t_proc)/                $ procedure
      40
      41/case(t_lab)/                 $ label
      42
      43/case(t_latom)/               $ long atom
      44
      45      go to error;
      46
      47
      48/case(t_elmt)/                $ element
      49
      50      deref(a);
      51      go to switch;
      52
      53
      54/case(t_lint)/                $ long integer
      55
mjsa 706      if ltli(a, zero) then   $ a < 0:  return - a
mjsa 707          sabs = uminli(a);
mjsa 708      else
mjsa 709          sabs = a;
mjsa 710      end if;
      71
      72      return;
      73
      74
      75/case(t_istring)/             $ long character string
      76
      77      ss = value_ a;
      78
      79      if ss_len(ss) ^= 1 then $ invalid string length
      80          go to error2;
      81      else
      82          v = icchar(ss, 1);
      83      end if;
      84
      85      build_spec(sabs, t_int, v);
      86      return;
      87
      88
      89/case(t_real)/                $ real
      90
      91      r = rval(value_ a);
      92
      93      if r >= 0.0 then
      94          sabs = a;
      95      else
      96          get_real(p);
      97          rval(p) = -r;
      98          build_spec(sabs, t_real, p);
      99      end if;
     100
     101      return;
     102
     103
     104/case(t_tuple)/               $ standard tuple
     105
     106/case(t_stuple)/              $ packed or untyped tuple
     107
     108/case(t_set)/                 $ set
     109
     110/case(t_map)/                 $ map
     111
     112      go to error;
     113
     114
     115case_om;    $ om type
     116
     117      call err_om(21);
     118      sabs = err_val(f_gen);
     119      return;
     120
     121
     122/error/   $ type error
     123
     124      call err_type(44);
     125      sabs = err_val(f_gen);
     126      return;
     127
     128
     129/error2/
     130
     131      call err_misc(49);
     132      sabs = err_val(f_gen);
     133      return;
     134
     135
     136      end fnct sabs;
       1 .=member schar
       2      fnct schar(arg);
       3
       4$ this is the setl -char n- routine.  it converts an integer in the
       5$ range 0 ... 2**chsiz-1 into a character string of length one.
       6
       7
       8      size arg(hs);           $ specifier for integer
       9
      10      size schar(hs);         $ specifier returned
      11
      12      size a(hs);             $ local copy of arg
      13      size v(ws);             $ integer value of arg
      16
      17
      18      a = arg;    deref(a);
      19
      20      if otype_ a ^= t_int then   $ invalid arguement
      21          if is_om_ a then
      22              call err_om(35);
      23          else
      24              call err_type(65);
      25          end if;
      26
      27          schar = err_val(f_string);
      28
      29      else
      30          v = ivalue_ a;
      31
      32          if v >= pow2(chsiz) then
      33              call err_misc(50);
      34              schar = err_val(f_string);
      35
      36          else
stra 570              schar = spec_char;  $ one-character template
stra 571              scchar(schar, 1) = v;
      40          end if;
      41      end if;
      42
      43
      44      end fnct schar;
       1 .=member ceil
       2      fnct ceil(arg);
       3
       4$ this is the setl 'ceil' function.  it computes the smallest
       5$ integer greater than or equal to a given real.
       6
       7
       8      size arg(hs);           $ specifier for real
       9
      10      size ceil(hs);          $ specifier returned
      11
      12      size a(hs);             $ local copy of arg
mjsa 711      real r1, r2;            $ real temporaries
mjsa 712
mjsa 713      size addli(hs);         $ adds two integers
mjsa 714      size fixli(hs);         $ converts a real to an integer
mjsa 715      size floatli(hs);       $ converts an integer to a real
      15
      16
      17      a = arg;   deref(a);
      18
      19      if otype_ a ^= t_real then $ invalid argument
      20          if is_om_ a then
      21              call err_om(24);
      22          else
      23              call err_type(58);
      24          end if;
      25
mjsa 716          ceil = err_val(f_int);
      27
      28      else
mjsa 717          ceil = fixli(a);
mjsa 718
smfc 229          r1 = rval(value_ a);
smfc 230
smfc 231          if abs(r1) <= float(.f. 1, real_mant_sz, all_ones) then
smfc 232              r2 = rval(value_ floatli(ceil));
smfc 233              if (r1 > r2) ceil = addli(ceil, one);
mjsa 723          end if;
      32      end if;
      33
      34
      35      end fnct ceil;
       1 .=member floor
       2      fnct floor(arg);
       3
       4$ this is the setl 'floor' function.  it computes the largest
       5$ integer less than or equal to a given real.
       6
       7
       8      size arg(hs);           $ specifier for real
       9
      10      size floor(hs);         $ specifier returned
      11
      12      size a(hs);             $ local copy of arg
mjsa 724      real r1, r2;            $ real temporaries
mjsa 725
mjsa 726      size diffli(hs);        $ subtracts two integers
mjsa 727      size fixli(hs);         $ converts a real to an integer
mjsa 728      size floatli(hs);       $ converts an integer to a real
      15
      16
      17      a = arg;   deref(a);
      18
      19      if otype_ a ^= t_real then $ invalid argument
      20          if is_om_ a then
      21              call err_om(25);
      22          else
      23              call err_type(59);
      24          end if;
      25
mjsa 729          floor = err_val(f_int);
      27
      28      else
mjsa 730          floor = fixli(a);
mjsa 731
smfc 234          r1 = rval(value_ a);
smfc 235
smfc 236          if abs(r1) <= float(.f. 1, real_mant_sz, all_ones) then
smfc 237              r2 = rval(value_ floatli(floor));
smfc 238              if (r1 < r2) floor = diffli(floor, one);
mjsa 736          end if;
      32      end if;
      33
      34
      35      end fnct floor;
       1 .=member sfix
       2      fnct sfix(arg);
       3
       4$ this is the setl 'fix' function.  it computes the largest
       5$ integer whose absolute value is less than or equal to the
       6$ absolute value of a given real.  the result has the same
       7$ sign as the argument.
       8
       9
      10      size arg(hs);           $ specifier for real
      11
      12      size sfix(hs);          $ specifier returned
      13
      14      size a(hs);             $ local copy of arg
      15      size v(ws);             $ (integer) value of arg
      16      real r;                 $ real temporary
mjsa 737
mjsa 738      size fixli(hs);         $ function called
      17
      18
      19      a = arg;   deref(a);
      20
      21      if otype_ a ^= t_real then $ invalid argument
      22          if is_om_ a then
      23              call err_om(26);
      24          else
      25              call err_type(60);
      26          end if;
      27
      28          sfix = err_val(f_gen);
      29
      30      else
mjsa 739          sfix = fixli(a);
      34      end if;
      35
      36
      37      end fnct sfix;
       1 .=member sfloat
       2      fnct sfloat(arg);
       3
       4$ this is the setl 'float' function.  it converts an integer
       5$ to a real.
       6
       7
       8      size arg(hs);           $ specifier for integer
       9
      10      size sfloat(hs);        $ specifier returned
      11
      12      size a(hs);             $ local copy of arg
      13      size v(ws);             $ (integer) value of arg
      14      size p(ps);             $ pointer to real
      15      real r;                 $ real temporary
mjsa 740
mjsa 741      size floatli(hs);       $ function called
      16
      17
      18      a = arg;   deref(a);
      19
mjsa 742      if otype_ a = t_int then
mjsa 743          v = ivalue_ a;   r = float(v);
mjsa 744          get_real(p);   rval(p) = r;
mjsa 745          build_spec(sfloat, t_real, p);
mjsa 746
mjsa 747      elseif otype_ a = t_lint then
mjsa 748          sfloat = floatli(a);
mjsa 749
mjsa 750      else
mjsa 751          if is_om_ a then
mjsa 752              call err_om(27);
mjsa 753          else
mjsa 754              call err_type(61);
mjsa 755          end if;
mjsa 756
mjsa 757          sfloat = err_val(f_real);
mjsa 758      end if;
      36
      37
      38      end fnct sfloat;
       1 .=member relf
       2      fnct relf(fc, arg);
       3
       4$ this routine evaluates the real unary elementary functions.
       5
       6
       7      size fc(ps);            $ function code
       8      size arg(hs);           $ spcifier for argument
       9
      10      size relf(hs);          $ specifier returned
      11
      12      size a(hs);             $ local copy of arg
      13      real r;                 $ result value
      14      real v;      $ argument value
      15      size p(hs);  $ pointer to result
      16
      17
      18$ erty gives error code if wrong type.
      19
      20      size  erty(ps);  dims  erty(relf_max);
      21      data erty(relf_acos) = 68;
      22      data erty(relf_asin) = 69;
      23      data erty(relf_atan) = 70;
      24      data erty(relf_cos)  = 71;
      25      data erty(relf_exp)  = 72;
      26      data erty(relf_log)  = 73;
      27      data erty(relf_sin)  = 74;
      28      data erty(relf_sqrt) = 75;
      29      data erty(relf_tan)  = 76;
      30      data erty(relf_tanh) = 77;
      31
      32$ erom gives error code if argument undefined.
      33
      34      size erom(ps);  dims  erom(relf_max);
      35      data erom(relf_acos) = 38;
      36      data erom(relf_asin) = 39;
      37      data erom(relf_atan) = 40;
      38      data erom(relf_cos)  = 41;
      39      data erom(relf_exp)  = 42;
      40      data erom(relf_log)  = 43;
      41      data erom(relf_sin)  = 44;
      42      data erom(relf_sqrt) = 45;
      43      data erom(relf_tan)  = 46;
      44      data erom(relf_tanh) = 47;
      45
      46$ erdom gives error code if argument not in domain.
      47$ code is zero if domain error not possible, else if
      48$ err_misc error number.
      49
      50      size erdom(ps);  dims  erdom(relf_max);
      51      data erdom(relf_acos) = 52;
      52      data erdom(relf_asin) = 53;
      53      data erdom(relf_atan) = 0;
      54      data erdom(relf_cos)  = 0;
      55      data erdom(relf_exp)  = 0;
      56      data erdom(relf_log)  = 54;
      57      data erdom(relf_sin)  = 0;
      58      data erdom(relf_sqrt) = 55;
      59      data erdom(relf_tan)  = 0;
      60      data erdom(relf_tanh) = 47;
      61
      62
      63      a = arg;  deref(a);
      64
      65      if otype_ a ^= t_real then
      66          if is_om_ a then
      67              call err_om(erom(fc));
      68          else
      69              call err_type(erty(fc));
      70          end if;
      71
      72          relf = err_val(f_real);
      73          return;
      74      end if;
      75
      76      v = rval(value_ a);
      77
      78      go to case(fc) in relf_min to relf_max;
      79
      80
      81/case(relf_acos)/  $ acos
      82
smff  13      if ( ^ (-1.0 <= v & v <= 1.0)) go to domerr;
      84
      85$ use the identity  acos x = pi/2 - atan2(x, sqrt(1-x*x))
      86      r = atan2(1.0, 0.0) - atan2(v, sqrt(1.0 - v*v));
      87      go to done;
      88
      89
      90/case(relf_asin)/  $ asin
      91
smff  14      if ( ^ (-1.0 <= v & v <= 1.0)) go to domerr;
      93
      94$ use the identity  asin(x) = atan2(x, sqrt(1.0-x*x)).
      95      r = atan2(v, sqrt(1.0 - v*v));
      96      go to done;
      97
      98
      99/case(relf_atan)/  $ atan
     100
     101      r = atan(v);
     102      go to done;
     103
     104
     105/case(relf_cos)/  $ cos
     106
     107      r = cos(v);
     108      go to done;
     109
     110
     111/case(relf_exp)/  $ exp
     112
     113      r = exp(v);
     114      go to done;
     115
     116
     117/case(relf_log)/  $ log
     118
     119      if (v<=0.0) go to domerr;
     120      r = alog(v);
     121      go to done;
     122
     123
     124/case(relf_sin)/  $ sin
     125
     126      r = sin(v);
     127      go to done;
     128
     129
     130/case(relf_sqrt)/  $ sqrt
     131
     132      if (v<0.0) go to domerr;
     133      r = sqrt(v);
     134      go to done;
     135
     136
     137/case(relf_tan)/  $ tan
     138
     139$ evaluate tan(x) = sin(x) / cos(x) with error if cos(x) is zero.
     140
     141      r = cos(v);
     142      if (r=0.0) go to domerr;
     143      r = sin(v) / r;
     144      go to done;
     145
     146
     147/case(relf_tanh)/  $ tanh
     148
     149      r = tanh(v);
     150      go to done;
     151
     152
     153/done/
     154
     155      get_real(p);
     156      rval(p) = r;
     157      build_spec(relf, t_real, p);
     158
     159      return;
     160
     161
     162/domerr/   $ here if argument not in domain
     163
     164      call err_misc(erdom(fc));
     165      relf = err_val(f_real);
     166
     167      return;
     168
     169
     170      end fnct relf;
       1 .=member atan2f
       2      fnct atan2f(arg1, arg2);
       3
       4$ this function computes atan2 of its two arguments.
       5
       6
       7      size arg1(hs);          $ specifiers for arguments
       8      size arg2(hs);
       9
      10      size atan2f(hs);        $ specifier returned
      11
      12      size a1(hs);            $ local copies of arguments
      13      size a2(hs);
      14      size temp(ws);          $ word-sized temporary
      15
      16      real real1, real2, r;   $ real values of operands and result
      17
      18
      19      a1 = arg1;  deref(a1);
      20
      21      if otype_ a1 ^= t_real then
      22          if is_om_ a1 then
      23              call err_om(36);
      24          else
      25              call err_type(66);
      26          end if;
      27
      28          atan2f = err_val(f_real);
      29          return;
      30      end if;
      31
      32      a2 = arg2;  deref(a2);
      33
      34      if otype_ a2 ^= t_real then
      35          if is_om_ a2 then
      36              call err_om(37);
      37          else
      38              call err_type(67);
      39          end if;
      40
      41          atan2f = err_val(f_real);
      42          return;
      43      end if;
      44
      45      real1 = rval(value_ a1);
      46      real2 = rval(value_ a2);
      47
      48      r = atan2(real1, real2);   temp = r;
      49
      50      put_realval(temp, atan2f);
      51
      52
      53      end fnct atan2f;
       1 .=member rand
       2      fnct srand(arg);
       3
       4$ this is the setl random function.
       5
       6
       7      size arg(hs);           $ specifier for argument
       8
       9      size srand(hs);          $ specifier returned
      10
      11      size a(hs);             $ local copy of arg
      12
      13      size v(hs);             $ integer value
mjsa 759      size temp(hs);          $ temporary variable
      14      size n(ps);             $ cardinality of set or map
      15      size indx(hs);          $ tuple index
      16      size elmt(hs);          $ element in set iteration
      17      size iter(hs);          $ iterator form of elmt
      18      size p(hs);             $ pointer to long int
      19      size i(ps);             $ loop index
      20
      21      size arbs(hs);  $ pick element
mjsa 760      size ltli(1);           $ arithmetic functions called
mjsa 761      size addli(hs);
mjsa 762      size diffli(hs);
mjsa 763      size fixli(hs);
mjsa 764      size floatli(hs);
      22
      23      real rr;     $ real temporary
      24      real r;     $ real
      25
      26
      27      a = arg;
      28
      29      call randr(rr);  $ get next random real
      30
      31/switch/
      32
      33      go to case(otype_ a) in t_min to t_max;
      34
      35
      36/case(t_int)/        $ short int
      37
      38      v = ifix(rr * float(1 + value_ a));
      39      build_spec(srand, t_int, v);
      40      return;
      41
      42
      43/case(t_string)/      $ short chars
      44
      45/case(t_atom)/       $ short atom
      46
      47/case(t_proc)/
      48
      49/case(t_lab)/
      50
      51/case(t_latom)/      $ 'long' atom
      52
      53      go to error;
      54
      55
      56/case(t_elmt)/       $ compressed element
      57
      58      deref(a);   go to switch;
      59
      60
      61/case(t_lint)/       $ long integer
      62
mjsa 765      if ltli(zero, a) then
mjsa 766          temp = diffli(a, one);
mjsa 767      else
mjsa 768          temp = addli(a, one);
mjsa 769      end if;
mjsa 770
mjsa 771      r = rval(value_ floatli(temp));
mjsa 772
mjsa 773      get_real(p);
mjsa 774      rval(p) = r * rr;
mjsa 775      build_spec(temp, t_real, p);
mjsa 776
mjsa 777      srand = fixli(temp);
      72
      73      return;
      74
      75
      76/case(t_istring)/     $ long chars
      77
      78      go to error;
      79
      80
      81/case(t_real)/       $ real
      82
      83      r = rval(value_ a);
      84
      85      get_real(p);
      86      rval(p) = r * rr;
      87      build_spec(srand, t_real, p);
      88
      89      return;
      90
      91
      92/case(t_tuple)/      $ standard tuple
      93
      94/case(t_stuple)/     $ packed or untyped tuple
      95
      96$ for tuple, find number of elements. if zero, return omega.
      97$ otherwise, pick random integer and use of to extract component.
      98
      99      v = nelt(value_ a);
     100
     101      v = ifix(rr * float(v)) + 1;
     102      build_spec(indx, t_int, v);
     103      call of(srand, a, indx);
     104      return;
     105
     106
     107/case(t_set)/        $ set
     108
     109/case(t_map)/        $ map
     110
     111$ for a set of map, find number of elements n, pick
     112$ random integer in range 1..n, and then iterate through argument
     113$ until reach corresponding element.
     114
     115      ok_nelt(a);  $ set element count
     116      n = nelt(value_ a);  $ get element count;
     117      if n = 0 then $ return omega if null.
     118          srand = arbs(a);
     119      else
     120      $   here to iterate through set.
     121          n = ifix(rr * float(n)) + 1; $ get index desired element
     122          call inext(elmt, iter, a);
     123          do  i = 1 to n;  call nexts(elmt, iter, a); end do;
     124          srand = elmt;
     125      end if;
     126      return;
     127
     128
     129case_om;    $ om type
     130
     131      call err_om(48);
     132      srand = err_val(f_gen);
     133
     134      return;
     135
     136/error/   $ type error
     137
     138      call err_type(78);
     139      srand = err_val(f_gen);
     140
     141
     142      end fnct srand;
       1 .=member randr
       2      subr randr(r);
       3
       4$ this procedure computes next pseudo-random real in interval
       5$ 0.0 to 1.0, including 0.0 but not including 1.0.
       6$ the generator used is suggested by j. f. gimpel in algorithms in
       7$ snobol4, john wiley and sons, new york, 1976, p. 343.
       8
       9      real r; $ result
      10      size ranvar(ws); data ranvar = 1; $ variable, initial value
      11
      12      ranvar = mod(ranvar * 4676, 414971);
      13      r = float(ranvar) / 414971.0;
      14
      15
      16      end subr randr;
       1 .=member shost
       2      fnct shost(na);
       3
       4$ this is the host function that provides an escape to the
       5$ host environment.  functions provided by host are not part
       6$ of the setl system and may differ from implementation to
       7$ implementation.
       8
       9$ the default implementation of host is, appropriately, to
      10$ return omega. any change to this is to be negotiated between
      11$ implementor and user.
      12
      13      size na(ps);            $ number of arguments
      14
      15      size shost(hs);         $ specifier returned
      16
      17
      18      shost = err_val(f_gen);
      19
      20
      21      end fnct shost;
       1 .=member isamap
       2      fnct isamap(arg);
       3
       4$ this routine determines if argument set can be converted to map.
       5
       6
       7      size arg(hs);           $ specifier for argument
       8
       9      size isamap(1);         $ flag returned
      10
      11      size a(hs);             $ local copy of argument
      12      size elmt(hs);          $ element for iteration
      13      size iter(hs);          $ iterator
      14
      15
      16      a = arg;   deref(a);
      17
      18      if (otype_ a = t_map)  go to pass;
      19      if (otype_ a ^= t_set) go to fail;
      20
      21      call inext(elmt, iter, arg);
      22
      23      while 1;
      24          call nexts(elmt, iter, arg);
      25          if (is_om_ iter) quit;
      26
      27          if (^ istuple(otype_ elmt)) go to fail;
      28          if (nelt(value_ elmt) ^= 2) go to fail;
      29          if (is_om_ tcomp(value_ elmt, 1)) go to fail;
      30      end while;
      31
      32/pass/
      33      isamap = yes;   return;
      34
      35/fail/
      36      isamap = no;    return;
      37
      38
      39      end fnct isamap;
       1 .=member istype
       2 fnct istype(typ, arg);
       3 $ return -little- true if arg of type typ given by ist_ code.
       4      size typ(ps);  $ ist_ type value
       5      size arg(hs);  $ specifier
       6      size istype(1); $ result
       7      size a(hs);    $ specifier
       8      size isamap(hs);  $ function to test for map
       9
      10      a = arg;  deref(a);
      11      go to case(typ) in 1 to ist_max;
      12
      13/case(ist_int)/              $ is_integer
      14
      15      if (otype_ a = t_int)  go to pass;
      16      if (otype_ a = t_lint) go to pass;
      17
      18      go to fail;
      19
      20
      21/case(ist_rea)/             $ is_real
      22
      23      if (otype_ a = t_real) go to pass;
      24      go to fail;
      25
      26
      27/case(ist_str)/              $ is_string
      28
      29      if (otype_ a = t_string)  go to pass;
      30      if (otype_ a = t_istring) go to pass;
      31      go to fail;
      32
      33
      34/case(ist_boo)/             $ is_boolean
      35
      36      if (eq(a, heap(s_true)))  go to pass;
      37      if (eq(a, heap(s_false))) go to pass;
      38      go to fail;
      39
      40
      41/case(ist_ato)/             $ is_atom
      42
      43      if (otype_ a = t_atom)  go to pass;
      44      if (otype_ a = t_latom) go to pass;
      45      go to fail;
      46
      47
      48/case(ist_pri)/             $ is_primitive
      49
      50      if (isprim(otype_ a)) go to pass;
      51      go to fail;
      52
      53
      54/case(ist_tup)/              $ is_tuple
      55
      56
      57      if (istuple((otype_ a))) go to pass;
      58      go to fail;
      59
      60
      61/case(ist_set)/              $ is_set
      62
      63      if (isset((otype_ a))) go to pass;
      64      go to fail;
      65
      66/case(ist_map)/              $ is_map
      67
      68      if (otype_ a = t_map)  go to pass;
      69      if (otype_ a ^= t_set & otype_ a ^= t_elmt) go to fail;
      70
      71      if (isamap(a)) go to pass;
      72      go to fail;
      73
      74
      75 /pass/  istype = 1;  $ success
      76      return;
      77
      78 /fail/  istype = 0;  $ failure
      79
      80      end fnct istype;
      81
      82
       1 .=member getippr
       2      fnct sgtipp(na);
       3
       4$ this is the setl -getipp(str)- routine.  it simulates the
       5$ little -getipp- routine to read control card parameters.
       6
       7$ the argument -str- is a string of the form 'xxx=yyy/zzz'.
       8$ where:
       9
      10$ xxx:   the name of the parameter
      11$ yyy:   default if parameter not given
      12$ zzz:   default if only parameter name given
      13
      14$ -getippr- returns a specifier for an integer giving the
      15$ value of the parameter.
      16
      18
      19      size na(ps);            $ number of arguments
      20
      21      size sgtipp(hs);        $ specifier returned
      22
      23      size str(hs),           $ specifier for -str-
      24           parm(ps);          $ value of control card parameter
      25
      26      size bldsds(sds_sz),    $ functions called
      27           err_val(hs);
      28
      29
      32      str = stack_arg(1, 1);
      33
      34      if otype_ str ^= t_istring then
      35          call err_type(50);
      36          sgtipp = err_val(f_sint);
      37          return;
      38      end if;
      39
      40      call getipp(parm, bldsds(str));
      41      put_intval(parm, sgtipp);
      42
      43
      44      end fnct sgtipp;
       1 .=member getsppr
       2      fnct sgtspp(na);
       3
       4$ this is the setl -getspp(str)- routine.  it simulates the
       5$ little -getspp- routine to read control card parameters.
       6
       7$ the argument -str- is a string of the form 'xxx=yyy/zzz'.
       8$ (see getippr)
       9
      10$ -getsppr- returns a specifier for a string giving the value
      11$ of the parameter.
      12
      14
      15      size na(ps);            $ number of arguments
      16
      17      size sgtspp(hs);        $ specifier returned
      18
      19      size str(hs),           $ specifier for -str-
      20           parm(sds_sz);      $ parameter as little string
      21
      22      size bldsds(sds_sz),    $ functions called
      23           bldstr(hs),
      24           err_val(hs);
      25
      26
      29      str = stack_arg(1, 1);
      30
      31      if otype_ str ^= t_istring then
      32          call err_type(51);
      33          sgtspp = err_val(f_string);
      34          return;
      35      end;
      36
      37      call getspp(parm, bldsds(str));
      38
      39      sgtspp = bldstr(parm);
      40
      41
      42      end fnct sgtspp;
       1 .=member getem
       2      fnct getem(na);
       3
       4$ this is the setl -getem(a, b)- routine.  it assigns the values
       5$ of the runtime library variables -err_mode- and -err_limit- to
       6$ the variables -a- and -b-, resp.
       7
       8$ n.b.   since this is a subroutine call, -a- and -b- are passed
       9$        to -getem- through the stack.
      10
      11
      12      size na(ps);            $ number of arguments
      13
      14      size getem(hs);         $ specifier returned
      15
      16
      17      put_intval(err_mode,  stack_arg(1, 2));
      18      put_intval(err_limit, stack_arg(2, 2));
      19
      20
      21      getem = spec_om;
      22
      23
      24      end fnct getem;
       1 .=member setem
       2      fnct setem(na);
       3
       4$ this is the setl -setem(a, b)- routine.  it assigns the values
       5$ of the variables -a- and -b- to the runtime library
       6$ variables -err_mode- and -err_limit-, resp.
       7
       8
       9      size na(ps);            $ number of arguments
      10
      11      size setem(hs);         $ specifier returned
      12
      13      size em(hs),            $ specifier for new error mode
      14           el(hs);            $ specifier for new error limit
      15
      16
      17      em = ivalue_ stack_arg(1, 2);
      18      el = ivalue_ stack_arg(2, 2);
      19
      20      if (el < err_count) call err_fatal(13);
      21
      22      if em = err_mode then   $ just change error limit
      23          err_limit = el;
      24
      25$ there are four possible error modes, namely err_off (= 1),
      26$ err_part (= 2), err_opt (= 3), and err_full (= 4).  since
      27$ the code generator takes different actions depending on
      28$ the specified error mode, there are restrictions as to what
      29$ changes of err_mode are permissible at run-time.
      30
      31$ there is only one restriction:  one can not change from
      32$ err_mode = err_full to any other error mode, or from
      33$ err_off, err_part, or err_opt to err_full.
      34
      35$ the following test enforces this restriction.
      36
      37      elseif 0 < em & em <= err_opt & err_mode <= err_opt then
      38          err_mode  = em;
      39          err_limit = el;
      40
      41      else                    $ cannot change error mode
      42          call err_fatal(23);
      43      end if;
      44
      45
      46      setem = spec_om;
      47
      48
      49      end fnct setem;
       1 .=member break
       2      fnct break(na);
       3
stra 572      size na(ps);            $ number of arguments
stra 573      size break(hs);         $ specifier for matched string returned
       6
stra 574      size p(ps);             $ pointer to pattern set
stra 575      size j(ps);             $ loop index
stra 576      size c(cs);             $ current character
stra 577      size success(1);        $ success flag
      11
      12
      13      init_match;
      14
      15      success = no;
      16
      17      string_loop(c, j);
stra 578          if memb_patt(c, p) then
      19              success = yes;
stra 579              quit_string;
      21          end if;
      22      end_string;
      23
      24      match_result(break, j-1, success);
      25
      27
      28      end fnct break;
       1 .=member span
       2      fnct span(na);
       3
       4$ this is similar to 'break', but the matched string includes all
       5$ the characters in subject up to the first character which is not
       6$ in 'param'.
       7
stra 580      size na(ps);            $ number of arguments
stra 581      size span(hs);          $ specifier for matched string returned
      11
stra 582      size p(ps);             $ pointer to pattern set
stra 583      size j(ps);             $ loop index
stra 584      size c(cs);             $ current character
stra 585      size success(1);        $ success flag
      16
      17
      18      init_match;
      19
      20      success = no;
      21
      22      string_loop(c, j);
stra 586          if (^ memb_patt(c, p)) quit_string;
      24          success = yes;
      25      end_string;
      26
      27      match_result(span, j-1, success);
      28
      30
      31      end fnct span;
       1 .=member match
       2      fnct match(na);
       3
       4$ this is the setl 'match(a1, a2)' routine.
       5$
       6$ it is a short hand for:
       7$
       8$     return
       9$         if a1(1..#a2) = a2 then
      10$             a2              $ side effect: a1 := a1(#a2+1..);
      11$         else
      12$             om              $ no side effects
      13$         end;
      14
      15
      16      size na(ps);            $ number of arguments
      17
      18      size match(hs);         $ specifier returned
      19
      20      size a1(hs);            $ specifier for first argument
      21      size ss1(ssz);          $ string specifier for a1
      22      size l1(ps);            $ length of a1
      23
      24      size a2(hs);            $ specifier for second argument
      25      size ss2(ssz);          $ string specifier for a2
      26      size l2(ps);            $ length of a2
      27
stra 587      size cc(1);             $ condition code, result of string compare
stra 588      size success(1);        $ success flag
      32
      33
      34      a1 = stack_arg(1, 2);   $ get arguments
      35      a2 = stack_arg(2, 2);
      36
stra 589      if otype_ a1 = t_string then  $ subject is short string
stra 590          l1 = sc_nchars_ a1;  $ get length of subject
stra 591          if otype_ a2 = t_string then  $ param is short string
stra 592              l2 = sc_nchars_ a2;  $ get length of param
stra 593              if l2 = 0 then  $ param is null
stra 594                  build_spec(match, t_string, 0);
stra 595                  return;
stra 596              end if;
stra 597              if l2 > l1 then
stra 598                  success = no;
stra 599              else
stra 600                  success = (scchar(a1, 1) = scchar(a2, 1));
stra 601              end if;
stra 602          else    $ param is long string
stra 603              ss2 = value_ a2;  $ get pointer to string block
stra 604              l2 = ss_len(ss2);  $ get lenght of param
stra 605              if l2 = 0 then  $ param is null
stra 606                  build_spec(match, t_string, 0);
stra 607                  return;
stra 608              end if;
stra 609              if l2 > l1 then
stra 610                  success = no;
stra 611              else
stra 612                  success = (scchar(a1, 1) = icchar(ss2, 1));
stra 613              end if;
stra 614          end if;
stra 615      else    $ subject is long string
stra 616          ss1 = value_ a1;  $ get pointer to string block
stra 617          l1 = ss_len(ss1);  $ get lenght of subject
stra 618          if otype_ a2 = t_string then  $ param is short string
stra 619              l2 = sc_nchars_ a2;  $ get length of param
stra 620              if l2 = 0 then  $ param is null
stra 621                  build_spec(match, t_string, 0);
stra 622                  return;
stra 623              end if;
stra 624              if l2 > l1 then
stra 625                  success = no;
stra 626              else
stra 627                  success = (icchar(ss1, 1) = scchar(a2, 1));
stra 628              end if;
stra 629          else    $ param is long string
stra 630              ss2 = value_ a2;  $ get pointer to string block
stra 631              l2 = ss_len(ss2);  $ get lenght of param
stra 632              if l2 = 0 then  $ param is null
stra 633                  build_spec(match, t_string, 0);
stra 634                  return;
stra 635              end if;
stra 636              if l2 > l1 then
stra 637                  success = no;
stra 638              else
stra 639                  clc(cc, ss1, ss2, l2);
stra 640                  success = (cc = 0);
stra 641              end if;
stra 642          end if;
stra 643      end if;
stra 644
stra 645      match_result(match, l2, success);
      70
      71
      72      end fnct match;
       1 .=member lpad
       2      fnct lpad(na);
       3
       4$ this is the setl -lpad(str, n)- routine.
       5
       6$ it is a short hand for:
       7
asca  55$     if #str > n then
       9$         return str;
      10$     else
asca  56$         return ' ' * (n - #str) + str;
      12$     end if;
      14
      15      size na(ps);            $ number of arguments
      17      size lpad(hs);          $ specifier returned
      18
stra 646      size str(ssz);          $ specifier for subject
stra 647      size ss1(ssz);          $ string specifier for subject
stra 648      size len(ps);           $ length of subject
stra 649      size n(ps);             $ length of result
stra 650      size ss(ssz);           $ string specifier for result
stra 651      size blank(cs);         $ blank character
stra 652      size j(ps);             $ loop index
      26
stra 653      size nulllc(ssz);       $ allocates null string
asca  58 .+ascebc size aschar(cs);    $ ebcdic-to-ascii conversion
      29
      30
asca  59      blank = 1r ;
asca  60 .+ascebc if (ascebc_flag) blank = aschar(blank);  $ convert to ascii
asca  61
stra 654      str = subject;  n = ivalue_ param;
stra 655
stra 656      if otype_ str = t_string then  $ subject is short
stra 657          len = sc_nchars_ str;  $ get length of subject
stra 658          if len > n then
stra 659              lpad = str;  $ return subject string
stra 660          else
stra 661              ss = nulllc(n);  $ allocate result string block
stra 662              ss_len(ss) = n;  $ set length of result
stra 663              do j = 1 to n-len;  icchar(ss, j) = blank;  end do;
stra 664              if len then  icchar(ss, n) = scchar(str, 1);  end if;
stra 665              build_spec(lpad, t_istring, ss);
stra 666          end if;
stra 667      else    $ subject is long string
stra 668          ss1 = value_ str;  $ get pointer to string block
stra 669          len = ss_len(ss1);  $ get length of subject
stra 670          if len > n then
stra 671              lpad = str;  $ return subject string
stra 672          else
stra 673              ss = nulllc(n);  $ allocate result string block
stra 674              ss_len(ss) = n;  $ set length of result
stra 675              do j = 1 to n-len;  icchar(ss, j) = blank;  end do;
stra 676              ss_ofs(ss) = ss_ofs(ss) + (n-len);
stra 677              mvc(ss, ss1, len);
stra 678              ss_ofs(ss) = ss_ofs(ss) - (n-len);
stra 679              build_spec(lpad, t_istring, ss);
stra 680          end if;
stra 681      end if;
      54
      55
      56      end fnct lpad;
       1 .=member len
       2      fnct len(na);
       3
       4$ this is the setl 'len(str, n)' routine.
       5$
       6$ it is a short hand for:
       7$
       8$     return
       9$         if #str < n then
      10$             om              $ no side effects
      11$         else
      12$             str(1..n)       $ side effect: str := str(n+1..);
      13$         end;
      14
      15
      16      size na(ps);            $ number of arguments
stra 682      size len(hs);           $ specifier returned
      17
      18      size str(hs);           $ specifier for string
      19      size n(ps);             $ length of result
      20
      23      size ss1(ssz);          $ string specifier for first argument
      24      size len1(ps);          $ length of first argument
      25      size ofs1(ps);          $ string offset of first argument
      26      size ss(ssz);           $ string specifier for result
      27
      28
stra 683      str = subject;  n = ivalue_ param;
stra 684
stra 685      if n = 0 then  $ result is null, input unchanged
stra 686          build_spec(len, t_string, 0);
stra 687          return;
stra 688      end if;
stra 689
stra 690      if otype_ str = t_istring then  $ subject is long string
stra 691          ss1  = value_ str;  $ get pointer to string block
stra 692          len1 = ss_len(ss1);  $ get length of subject
stra 693          ofs1 = ss_ofs(ss1);  $ initial offset of subject
stra 694
stra 695          if len1 < n then  $ subject too short:  fail
stra 696              len = heap(ft_samp(f_sstring));
stra 697          else
stra 698              build_ss(ss, ss_ptr(ss1), ofs1, n);
stra 699              build_spec(len, t_istring, ss);
stra 700
stra 701              build_ss(ss, ss_ptr(ss1), ofs1 + n, len1 - n);
stra 702              build_spec(str, t_istring, ss);
stra 703
stra 704              subject = str;
stra 705          end if;
stra 706
stra 707      else    $ subject is short string
stra 708          len1 = sc_nchars_ str;  $ get length of subject
stra 709          if len1 < n then  $ subject too short:  fail
stra 710              len = heap(ft_samp(f_sstring));
stra 711          else
stra 712              len = str;  value_ str = 0;
stra 713              subject = str;
stra 714          end if;
stra 715      end if;
      48
      49
      50      end fnct len;
       1 .=member any
       2      fnct sany(na);
       3
       4$ this is another pattern matching primitive. it succeeds if the
       5$ first character of the subject is in the parameter set.
       6
stra 716      size na(ps);            $ number of arguments
stra 717      size sany(hs);          $ specifier returned
       9
stra 718      size p(ps);             $ pointer to param set
stra 719      size str(hs);           $ specifier for subject
stra 720      size ss(ssz);           $ string specifier for subject
stra 721      size c(cs);             $ first character
stra 722      size success(1);        $ success flag
      14
stra 723
stra 724      str = subject;  $ get specifier for subject string
stra 725
stra 726      until 1;
stra 727          if otype_ str = t_string then  $ subject is short string
stra 728              if sc_nchars_ str = 0 then  $ subject is null
stra 729                  success = no;  $ set to failure
stra 730                  quit until;  $ no character to be checked
stra 731              else
stra 732                  c = scchar(str, 1);  $ get first character
stra 733              end if;
stra 734          else    $ subject is long string
stra 735              ss = value_ str;  $ get pointer to character block
stra 736              if ss_len(ss) = 0 then  $ subject is null
stra 737                  success = no;  $ set to failure
stra 738                  quit until;  $ no character to be checked
stra 739              else
stra 740                  c = icchar(ss, 1);  $ get first character
stra 741              end if;
stra 742          end if;
stra 743
stra 744          init_match;
stra 745          success = memb_patt(c, p);
stra 746      end until;
      25
      26      match_result(sany, 1, success);
      27
      29
      30      end fnct sany;
       1 .=member notany
       2      fnct notany(na);
stra 747
       3$ this is another pattern matching primitive. it succeeds if the
       4$ first character of the subject is not in the parameter set.
       5
stra 748      size na(ps);            $ number of arguments
stra 749      size notany(hs);        $ specifier returned
       8
stra 750      size p(ps);             $ pointer to param set
stra 751      size str(hs);           $ specifier for subject
stra 752      size ss(ssz);           $ string specifier for subject
stra 753      size c(cs);             $ first character
stra 754      size success(1);        $ success flag
      13
stra 755
stra 756      str = subject;  $ get specifier for subject string
stra 757
stra 758      until 1;
stra 759          if otype_ str = t_string then  $ subject is short string
stra 760              if sc_nchars_ str = 0 then  $ subject is null
stra 761                  success = no;  $ set to failure
stra 762                  quit until;  $ no character to be checked
stra 763              else
stra 764                  c = scchar(str, 1);  $ get first character
stra 765              end if;
stra 766          else    $ subject is long string
stra 767              ss = value_ str;  $ get pointer to character block
stra 768              if ss_len(ss) = 0 then  $ subject is null
stra 769                  success = no;  $ set to failure
stra 770                  quit until;  $ no character to be checked
stra 771              else
stra 772                  c = icchar(ss, 1);  $ get first character
stra 773              end if;
stra 774          end if;
stra 775
stra 776          init_match;
stra 777          success = (memb_patt(c, p) = no);
stra 778      end until;
      24
      25      match_result(notany, 1, success);
      26
      28
      29      end fnct notany;
       1 .=member rbreak
       2      fnct rbreak(na);
       3
stra 779      size na(ps);            $ number of arguments
stra 780      size rbreak(hs);        $ specifier for matched string returned
       6
stra 781      size p(ps);             $ pointer to pattern set
stra 782      size j(ps);             $ loop index
stra 783      size c(cs);             $ current character
stra 784      size success(1);        $ success flag
      11
      12
      13      init_match;
      14
      15      success = no;
      16
      17      rstring_loop(c, j);
      18          if memb_patt(c, p) then;
      19              success = yes;
stra 785              quit_string;
      21          end if;
      22      end_string;
      23
      24      rmatch_result(rbreak, ss_len(value_ subject) - j, success);
      25
      27
      28      end fnct rbreak;
       1 .=member rspan
       2      fnct rspan(na);
       3
       4$ this is similar to 'rbreak', but the matched string includes all
       5$ the characters in subject up to the first character which is not
       6$ in 'param'.
       7
stra 786      size na(ps);            $ number of arguments
stra 787      size rspan(hs);         $ specifier for matched string returned
      11
stra 788      size p(ps);             $ pointer to pattern set
stra 789      size j(ps);             $ loop index
stra 790      size c(cs);             $ current character
stra 791      size success(1);        $ success flag
      16
      17
      18      init_match;
      19
      20      success = no;
      21
      22      rstring_loop(c, j);
stra 792          if (^ memb_patt(c, p)) quit_string;
      24          success = yes;
      25      end_string;
      26
      27      rmatch_result(rspan, ss_len(value_ subject) - j, success);
      28
      30
      31      end fnct rspan;
       1 .=member rmatch
       2      fnct rmatch(na);
       3
       4$ this is the setl 'rmatch(a1, a2)' routine.
       5$
       6$ it is a short hand for:
       7$
       8$     return
       9$         if a1(#a1-#a2+1..) = a2 then
      10$             a2              $ side effect: a1 := a1(1..#a1-#a2);
      11$         else
      12$             om              $ no side effects
      13$         end;
      14
      15
      16      size na(ps);            $ number of arguments
      17
      18      size rmatch(hs);        $ specifier returned
      19
      20      size a1(hs);            $ specifier for first argument
      21      size ss1(ssz);          $ string specifier for a1
      22      size l1(ps);            $ length of a1
      23
      24      size a2(hs);            $ specifier for second argument
      25      size ss2(ssz);          $ string specifier for a2
      26      size l2(ps);            $ length of a2
      27
stra 793      size ss(ssz);           $ string specifier for -a1(#a1-#a2+1..)-
stra 794      size cc(1);             $ condition code, result of string compare
stra 795      size success(1);        $ success flag
      32
      33
      34      a1 = stack_arg(1, 2);   $ get arguments
      35      a2 = stack_arg(2, 2);
      36
stra 796      if otype_ a1 = t_string then  $ subject is short string
stra 797          l1 = sc_nchars_ a1;  $ get length of subject
stra 798          if otype_ a2 = t_string then  $ param is short string
stra 799              l2 = sc_nchars_ a2;  $ get length of param
stra 800              if l2 = 0 then  $ param is null
stra 801                  build_spec(rmatch, t_string, 0);
stra 802                  return;
stra 803              end if;
stra 804              if l2 > l1 then
stra 805                  success = no;
stra 806              else
stra 807                  success = (scchar(a1, 1) = scchar(a2, 1));
stra 808              end if;
stra 809          else    $ param is long string
stra 810              ss2 = value_ a2;  $ get pointer to string block
stra 811              l2 = ss_len(ss2);  $ get lenght of param
stra 812              if l2 = 0 then  $ param is null
stra 813                  build_spec(rmatch, t_string, 0);
stra 814                  return;
stra 815              end if;
stra 816              if l2 > l1 then
stra 817                  success = no;
stra 818              else
stra 819                  success = (scchar(a1, 1) = icchar(ss2, 1));
stra 820              end if;
stra 821          end if;
stra 822      else    $ subject is long string
stra 823          ss1 = value_ a1;  $ get pointer to string block
stra 824          l1 = ss_len(ss1);  $ get lenght of subject
stra 825          if otype_ a2 = t_string then  $ param is short string
stra 826              l2 = sc_nchars_ a2;  $ get length of param
stra 827              if l2 = 0 then  $ param is null
stra 828                  build_spec(rmatch, t_string, 0);
stra 829                  return;
stra 830              end if;
stra 831              if l2 > l1 then
stra 832                  success = no;
stra 833              else
stra 834                  success = (icchar(ss1, l1) = scchar(a2, 1));
stra 835              end if;
stra 836          else    $ param is long string
stra 837              ss2 = value_ a2;  $ get pointer to string block
stra 838              l2 = ss_len(ss2);  $ get lenght of param
stra 839              if l2 = 0 then  $ param is null
stra 840                  build_spec(rmatch, t_string, 0);
stra 841                  return;
stra 842              end if;
stra 843              if l2 > l1 then
stra 844                  success = no;
stra 845              else
stra 846                  build_ss(ss, ss_ptr(ss1), ss_ofs(ss1)+l1-l2, l2)
stra 847                  clc(cc, ss, ss2, l2);
stra 848                  success = (cc = 0);
stra 849              end if;
stra 850          end if;
stra 851      end if;
stra 852
stra 853      rmatch_result(rmatch, l2, success);
      70
      71
      72      end fnct rmatch;
       1 .=member rpad
       2      fnct rpad(na);
       3
       4$ this is the setl -rpad(str, n)- routine.
       5
       6$ it is a short hand for:
       7
asca  63$     if #str > n then
       9$         return str;
      10$     else
asca  64$         return str + ' ' * (n - #str);
      12$     end if;
      14
      15      size na(ps);            $ number of arguments
      17      size rpad(hs);          $ specifier returned
      18
stra 854      size str(ssz);          $ specifier for subject
stra 855      size ss1(ssz);          $ string specifier for subject
stra 856      size len(ps);           $ length of subject
stra 857      size n(ps);             $ length of result
stra 858      size ss(ssz);           $ string specifier for result
stra 859      size blank(cs);         $ blank character
stra 860      size j(ps);             $ loop index
      26
stra 861      size nulllc(ssz);       $ allocates null string
asca  66 .+ascebc size aschar(cs);    $ ebcdic-to-ascii conversion
      29
      30
asca  67      blank = 1r ;
asca  68 .+ascebc if (ascebc_flag) blank = aschar(blank);  $ convert to ascii
asca  69
stra 862      str = subject;  n = ivalue_ param;
stra 863
stra 864      if otype_ str = t_string then  $ subject is short
stra 865          len = sc_nchars_ str;  $ get length of subject
stra 866          if len > n then
stra 867              rpad = str;  $ return subject string
stra 868          else
stra 869              ss = nulllc(n);  $ allocate result string block
stra 870              ss_len(ss) = n;  $ set length of result
stra 871              if len then  icchar(ss, 1) = scchar(str, 1);  end if;
stra 872              do j = len+1 to n;  icchar(ss, j) = blank;  end do;
stra 873              build_spec(rpad, t_istring, ss);
stra 874          end if;
stra 875      else    $ subject is long string
stra 876          ss1 = value_ str;  $ get pointer to string block
stra 877          len = ss_len(ss1);  $ get length of subject
stra 878          if len > n then
stra 879              rpad = str;  $ return subject string
stra 880          else
stra 881              ss = nulllc(n);  $ allocate result string block
stra 882              ss_len(ss) = n;  $ set length of result
stra 883              mvc(ss, ss1, len);
stra 884              do j = len+1 to n;  icchar(ss, j) = blank;  end do;
stra 885              build_spec(rpad, t_istring, ss);
stra 886          end if;
stra 887      end if;
      54
      55
      56      end fnct rpad;
       1 .=member rlen
       2      fnct rlen(na);
       3
       4$ this is the setl 'rlen(str, n)' routine.
       5$
       6$ it is a short hand for:
       7$
       8$     return
       9$         if #str < n then
      10$             om              $ no side effects
      11$         else
      12$             str(#str-n+1..) $ side effect: str := str(1..#str-n);
      13$         end;
      14
      15
      16      size na(ps);            $ number of arguments
stra 888      size rlen(hs);          $ specifier returned
      17
      18      size str(ssz);          $ string specifier for first argument
      19      size n(ps);             $ length of result
      20
      23      size ss1(ssz);          $ string specifier for first argument
      24      size len1(ps);          $ length of first argument
      25      size ofs1(ps);          $ string offset of first argument
      26      size ss(ssz);           $ string specifier for result
      27
stra 889
stra 890      str = subject;  n = ivalue_ param;
stra 891
stra 892      if n = 0 then  $ result is null, input unchanged
stra 893          build_spec(rlen, t_string, 0);
stra 894          return;
stra 895      end if;
stra 896
stra 897      if otype_ str = t_istring then  $ subject is long string
stra 898          ss1  = value_ str;  $ get pointer to string block
stra 899          len1 = ss_len(ss1);  $ get length of subject
stra 900          ofs1 = ss_ofs(ss1);  $ initial offset of subject
stra 901
stra 902          if len1 < n then  $ subject too short:  fail
stra 903              rlen = heap(ft_samp(f_sstring));
stra 904          else
stra 905              build_ss(ss, ss_ptr(ss1), ofs1+len1-n, n);
stra 906              build_spec(rlen, t_istring, ss);
stra 907
stra 908              build_ss(ss, ss_ptr(ss1), ofs1, len1 - n);
stra 909              build_spec(str, t_istring, ss);
stra 910
stra 911              subject = str;
stra 912          end if;
stra 913
stra 914      else    $ subject is short string
stra 915          len1 = sc_nchars_ str;  $ get length of subject
stra 916          if len1 < n then  $ subject too short:  fail
stra 917              rlen = heap(ft_samp(f_sstring));
stra 918          else
stra 919              rlen = str;  value_ str = 0;
stra 920              subject = str;
stra 921          end if;
stra 922      end if;
      47
      48
      49      end fnct rlen;
       1 .=member rany
       2      fnct rany(na);
       3
       4$ this is another pattern matching primitive. it succeeds if the
       5$ first character of the subject is in the parameter set.
       6
stra 923      size na(ps);            $ number of arguments
stra 924      size rany(hs);          $ specifier returned
       9
stra 925      size p(ps);             $ pointer to param set
stra 926      size str(hs);           $ specifier for subject
stra 927      size ss(ssz);           $ string specifier for subject
stra 928      size len(ps);           $ length of subject string
stra 929      size c(cs);             $ first character
stra 930      size success(1);        $ success flag
      14
stra 931
stra 932      str = subject;  $ get specifier for subject string
stra 933
stra 934      until 1;
stra 935          if otype_ str = t_string then  $ subject is short string
stra 936              if sc_nchars_ str = 0 then  $ subject is null
stra 937                  success = no;  $ set to failure
stra 938                  quit until;  $ no character to be checked
stra 939              else
stra 940                  c = scchar(str, 1);  $ get last character
stra 941              end if;
stra 942          else    $ subject is long string
stra 943              ss = value_ str;  $ get pointer to character block
stra 944              len = ss_len(ss);  $ get length of subject string
stra 945              if len = 0 then  $ subject is null
stra 946                  success = no;  $ set to failure
stra 947                  quit until;  $ no character to be checked
stra 948              else
stra 949                  c = icchar(ss, len);  $ get last character
stra 950              end if;
stra 951          end if;
stra 952
stra 953          init_match;
stra 954          success = memb_patt(c, p);
stra 955      end until;
      25
      26      rmatch_result(rany, 1, success);
      27
      29
      30      end fnct rany;
       1 .=member rnotany
       2      fnct rnotany(na);
       3
       4$ this is another pattern matching primitive. it succeeds if the
       5$ first character of the subject is not in the parameter set.
       6
stra 956      size na(ps);            $ number of arguments
stra 957      size rnotany(hs);       $ specifier returned
       9
stra 958      size p(ps);             $ pointer to param set
stra 959      size str(hs);           $ specifier for subject
stra 960      size ss(ssz);           $ string specifier for subject
stra 961      size len(ps);           $ length of subject string
stra 962      size c(cs);             $ first character
stra 963      size success(1);        $ success flag
      14
stra 964
stra 965      str = subject;  $ get specifier for subject string
stra 966
stra 967      until 1;
stra 968          if otype_ str = t_string then  $ subject is short string
stra 969              if sc_nchars_ str = 0 then  $ subject is null
stra 970                  success = no;  $ set to failure
stra 971                  quit until;  $ no character to be checked
stra 972              else
stra 973                  c = scchar(str, 1);  $ get last character
stra 974              end if;
stra 975          else    $ subject is long string
stra 976              ss = value_ str;  $ get pointer to character block
stra 977              len = ss_len(ss);  $ get length of subject string
stra 978              if len = 0 then  $ subject is null
stra 979                  success = no;  $ set to failure
stra 980                  quit until;  $ no character to be checked
stra 981              else
stra 982                  c = icchar(ss, len);  $ get last character
stra 983              end if;
stra 984          end if;
stra 985
stra 986          init_match;
stra 987          success = (memb_patt(c, p) = no);
stra 988      end until;
      25
      26      rmatch_result(rnotany, 1, success);
      27
      29
      30      end fnct rnotany;
       1 .=member str
       2      fnct str(arg);
       3
       4$ this routine converts any setl object to a string giving its external
       5$ representation.
       6
asca  71 .+ascebc.
asca  72$ in ascii mode, the result string needs to be in ascii.  this is done
asca  73$ by assuming that -str- generates the correct ebcdic characters and
asca  74$ converting to ascii on the output that is done via local routine
asca  75$ write_char.  however, we assume that strings in input are ascii
asca  76$ already, so we convert the output character of each string from ascii
asca  77$ to ebcdic so that when we merge with write_char, the proper output
asca  78$ conversion will be done.
asca  79 ..ascebc
       7
       8      size arg(hs);           $ specifier for value to be converted
       9
      10      size str(hs);           $ specifier for result string
      11
      12      size a(hs);             $ local copy of arg
      13      size len(ps);           $ current length of str
      14      size ss1(ssz);          $ string specifier
      15      size ss2(ssz);          $ string specifier, used for copy
      16      size p(ps);             $ pointer to long string data block
      17      size source_ss(ssz);    $ string specifier
      18      size source_word(ps);   $ pointer to current word
      19      size source_offs(ps);   $ offset in current word
      20      size rout(sds_sz);      $ routine name
      21      size stmt(ps);          $ statement number
      22      size int1(ws);          $ signed integer
      23      size int2(ws);          $ signed integer
      24      size int3(ws);          $ signed integer
      25      size exp1(ws);          $ exponent of real number
      26      real real1;             $ real numbers
      27      size string1(sds_sz);   $ little string
      28      size val(hs);           $ packed or untyped value
      29      size om_val(hs);        $ untyped omega value
      30      size t1(hs);            $ temporary for set/tuple element
      31      size t2(hs);            $ temporary for set/tuple iterator
      32      size j(ps);             $ loop index
      33      size k(ps);             $ loop index
      34      size ptr1(ps);          $ pointer to current word
      35      size ofs1(ps);          $ offset in current word
      36      size new(ps);           $ junk pointer to get extra heap word
      37      size c(chsiz);          $ character code to be written
      38      size tstart(ps);        $ initial recursion stack pointer
      39      size ret_int(ps);       $ return address for write_int subroutine
      40      size ret_real(ps);      $ return address for write_real subroutine
      41      size ret_sds(ps);       $ return address for write_sds subroutine
      42
      43
      44$ stacked variables
      45
      46 .=zzyorg b                   $ reset counter for stack offsets
      47      local(retpt)            $ return pointer
      48
      49      local(temp1)            $ set/tuple element
      50      local(temp2)            $ set/tuple iterator
      51      local(temp3)            $ set/tuple specifier
      52
      53
      54      size nulllc(ssz);       $ returns string specifier for null string
smfc 239      size strli(hs);         $ converts long integer to string
smfc 240      size addstr(hs);        $ adds two strings
asca  80 .+ascebc.
asca  81      size ebchar(cs);        $ ascii-to-ebcdic conversion function
asca  82      size aschar(cs);        $ ebcdic-to-ascii conversion function
asca  83 ..ascebc
      55
      56
      57      a = arg;                $ local copy of argument
      58
      59      $ initialize result string
      60      ss1 = nulllc(1);   p = ss_ptr(ss1);
      61      assert ss_ofs(ss1) = 0;
      62      ptr1 = p + hl_lchars;   ofs1 = chorg;   len = 0;
      63
      64
      65 .=zzyorg a                   $ reset counter for return labels
      66      tstart = t;             $ save recursion stack pointer
      67
      68/entry/                       $ recursive entry point
      69      r_entry                 $ increment recursion stack
      70
      71
      72/switch/
      73
      74      if is_om_ a then
      75          if (type_ a = t_error) go to case(t_error);
      76
      77          c = 1r*;   l_call(write_char);
      78
      79      else
      80          go to case(otype_ a) in t_min to t_lmax;
      81
      82
      83/case(t_int)/                 $ short integer
      84
      85          int1 = ivalue_ a;   l_call(write_int);
      86
      87          go to exit;
      88
      89
      90/case(t_string)/              $ short character string
      91
      92          c = 1r';   l_call(write_char);
      93
      94          do j = 1 to sc_nchars_ a;
stra 989          c = scchar(a, j);
asca  84 .+ascebc.
asca  85              $ recall that -write-char- expects ebcdic character.
asca  86              if (ascebc_flag) c = ebchar(c);  $ convert to ebcdic
asca  87 ..ascebc
stra 990          l_call(write_char);
      96              if c = 1r' then l_call(write_char); end if;
      97          end do;
      98
      99          c = 1r';   l_call(write_char);
     100
     101          go to exit;
     102
     103
     104/case(t_atom)/                $ short atom or boolean
     105
     106          c = 1r#;   l_call(write_char);
     107
     108          if a = heap(s_true) then
     109              c = 1rt;   l_call(write_char);
     110          elseif a = heap(s_false) then
     111              c = 1rf;   l_call(write_char);
     112          else
     113              int1 = ivalue_ a;   l_call(write_int);
     114          end if;
     115
     116          go to exit;
     117
     118
     119/case(t_error)/               $ error value
     120
     121          call find_stmt(rout, stmt, value_ a);
     122          string1 = '*** error at proc: '; l_call(write_sds);
     123          string1 = rout;                  l_call(write_sds);
     124          string1 = ' stmt: ';             l_call(write_sds);
     125          int1    = stmt;                  l_call(write_int);
     126          string1 = ' addr: ';             l_call(write_sds);
     127          int1    = value_ a;              l_call(write_int);
     128          string1 = ' ***';                l_call(write_sds);
     129
     130          go to exit;
     131
     132
     133/case(t_proc)/                $ procedure
     134
     135/case(t_lab)/                 $ label
     136
     137          call err_misc(47);
     138          str = err_val(f_gen);
     139          return;
     140
     141
     142/case(t_latom)/               $ long atom
     143
     144          c = 1r#;                     l_call(write_char);
     145          int1 = la_value(value_ a);   l_call(write_int);
     146
     147          go to exit;
     148
     149
     150/case(t_elmt)/                $ element of base
     151
     152          deref(a);   go to switch;
     153
     154
     155/case(t_lint)/                $ long integer
     156
smfc 241          ss_len(ss1) = len;
smfc 242          build_spec(str, t_istring, ss1);
smfc 243
smfc 244          ss1 = value_ addstr(str, strli(a));
smfc 245
smfc 246          p = ss_ptr(ss1);   len = ss_len(ss1);
smfc 247          ptr1 = p + icoffs(ss1, len);   ofs1 = icorg(ss1, len);
smfc 248          if ss_ofs(ss1) ^= 0
smfc 249                  ! p + lc_nwords(p) ^= h
smfc 250                  ! lcalloc(len) ^= lc_nwords(p)
smfc 251                  ! ofs1 = chlst
smfc 252          then
smfc 253              ss2 = nulllc(len);  $ allocate new string block
smfc 254              mvc(ss2, ss1, len)  $ copy the string
smfc 255              ss1 = ss2;
smfc 256              p = ss_ptr(ss1);   ptr1 = p + icoffs(ss1, len);
smfc 257              ofs1 = icorg(ss1, len);
smfc 258          end if;
smfc 259          assert ss_ofs(ss1) = 0;
smfc 260          assert p + lc_nwords(p) = h;
smfc 261          assert lcalloc(len) = lc_nwords(p);
smfc 262          if ofs1 = chlst then
smfc 263              get_heap(1, new);   $ get extra word
smfc 264              lc_nwords(p) = lc_nwords(p) + 1;
smfc 265              ofs1 = chorg;   ptr1 = ptr1 + 1;
smfc 266          else
smfc 267              ofs1 = ofs1 + chinc;
smfc 268          end if;
     159
     160          go to exit;
     161
     162
     163/case(t_istring)/             $ long character string
     164
     165          c = 1r';   l_call(write_char);
     166
     167          source_ss   = value_ a;
     168          source_word = ss_ptr(source_ss) + icoffs(source_ss, 1);
     169          source_offs = icorg(source_ss, 1);
     170
     171          do j = 1 to ss_len(source_ss);
     172              c = .f. source_offs, chsiz, heap(source_word);
asca  88 .+ascebc.
asca  89              $ recall that -write-char- expects ebcdic character.
asca  90              if (ascebc_flag) c = ebchar(c);  $ convert to ebcdic
asca  91 ..ascebc
     173              l_call(write_char);
     174
     175              $ double internal quotes
     176              if c = 1r' then l_call(write_char); end if;
     177
     178              $ update word pointer and word offset in source string
     179              if source_offs = chlst then
     180                  source_offs = chorg;
     181                  source_word = source_word + 1;
     182              else
     183                  source_offs = source_offs + chinc;
     184              end if;
     185          end do;
     186
     187          c = 1r';   l_call(write_char);
     188
     189          go to exit;
     190
     191
     192/case(t_real)/                $ real
     193
     194          real1 = rval(value_ a);   l_call(write_real);
     195
     196          go to exit;
     197
     198
     199/case(t_tuple)/               $ standard tuple
     200
     201          c = ltb_char;   l_call(write_char);
     202          c = 1r ;        l_call(write_char);
     203
     204          t1 = value_ a;      $ get pointer to tuple data block
     205          t2 = 1;             $ component index
     206
     207          while t2 <= nelt(t1);
     208              a = tcomp(t1, t2);   t2 = t2 + 1;
     209
     210              temp1 = t1;   temp2 = t2;
     211              r_call;
     212              t1 = temp1;   t2 = temp2;
     213
     214              c = 1r ;    l_call(write_char);
     215          end while;
     216
     217          c = rtb_char;   l_call(write_char);
     218
     219          go to exit;
     220
     221
     222/case(t_stuple)/              $ packed or untyped tuple
     223
     224          c = ltb_char;   l_call(write_char);
     225          c = 1r ;        l_call(write_char);
     226
     227          t1 = value_ a;      $ get pointer to tuple data block
     228
     229          go to tc(htype(t1)) in h_ptuple to h_rtuple;
     230
     231
     232/tc(h_ptuple)/                $ packed tuple
     233
     234          t2 = 1;             $ component index
     235
     236          while t2 <= nelt(t1);
     237              val = pcomp(t1, t2);
     238              unpack(ptkey(t1), val, a);
     239
     240              t2 = t2 + 1;
     241
     242              temp1 = t1;   temp2 = t2;
     243              r_call;
     244              t1 = temp1;   t2 = temp2;
     245
     246              c = 1r ;    l_call(write_char);
     247          end while;
     248
     249          c = rtb_char;   l_call(write_char);
     250
     251          go to exit;
     252
     253
     254/tc(h_ituple)/                $ untyped integer tuple
     255
     256          om_val = tcomp(t1, 0);
     257
     258          do t2 = 1 to nelt(t1);
     259              val = tcomp(t1, t2);
     260
     261              if val = om_val then
     262                  c = 1r*;      l_call(write_char);
     263              else
     264                  int1 = val;   l_call(write_int);
     265              end if;
     266
     267              c = 1r ;    l_call(write_char);
     268          end do;
     269
     270          c = rtb_char;   l_call(write_char);
     271
     272          go to exit;
     273
     274
     275/tc(h_rtuple)/                $ untyped real tuple
     276
     277          om_val = tcomp(t1, 0);
     278
     279          do t2 = 1 to nelt(t1);
     280              val = tcomp(t1, t2);
     281
     282              if val = om_val then
     283                  c = 1r*;       l_call(write_char);
     284              else
     285                  real1 = val;   l_call(write_real);
     286              end if;
     287
     288              c = 1r ;    l_call(write_char);
     289          end do;
     290
     291          c = rtb_char;   l_call(write_char);
     292
     293          go to exit;
     294
     295
     296/case(t_set)/                 $ set
     297
     298/case(t_map)/                 $ map
     299
     300          c = lsb_char;   l_call(write_char);
     301
     302          call inext(t1, t2, a);
     303
     304          while 1;
     305              call nexts(t1, t2, a);
     306              if (is_om_ t2) quit while 1;
     307
     308              c = 1r ;    l_call(write_char);
     309
     310              temp1 = t1;   temp2 = t2;   temp3 = a;
     311              a = t1;   r_call;
     312              t1 = temp1;   t2 = temp2;   a = temp3;
     313          end while 1;
     314
     315          c = 1r ;        l_call(write_char);
     316          c = rsb_char;   l_call(write_char);
     317
     318          go to exit;
     319
     320
     321/case(t_skip)/                $ skip word before untyped data
     322          $
     323          $ this case should only be reached by the current snap
     324          $ routine.  unless an appropriate check is made there,
     325          $ we should just ignore this case here.  eventually
     326          $ we should add this check in the snap routine, as to
     327          $ catch cases where we actually try to apply str on
     328          $ skip words.
     329          $
     330          go to exit;
     331
     332
     333      end if;
     334
     335
     336/exit/                        $ recursive exit point
     337
     338      r_exit                  $ pop recursion stack
     339
     340      if t ^= tstart then     $ return to previous invocation
     341          go to rlab(retpt) in 1 to zzya;
     342      end if;
     343
     344      ss_len(ss1) = len;
     345      build_spec(str, t_istring, ss1)
     346      return;
     347
     348
     349/write_sds/                   $ local subroutine to write sds
     350
     351      ret_sds = retpt;
     352
     353      do k = 1 to slen string1;
     354          c = .ch. k, string1;    l_call(write_char);
     355          if c = 1r' then l_call(write_char); end if;
     356      end do;
     357
     358      go to rlab(ret_sds) in 1 to zzya;
     359
     360
     361/write_real/                  $ local subroutine to write signed real
     362
     363      ret_real = retpt;
     364
     365      if real1 < 0.0 then
     366          c = 1r-;   l_call(write_char);
     367          real1 = - real1;
     368      end if;
     369
     370      $ compute the exponent for the normalized real
     371      exp1 = 0;
     372      if real1 >= 10.0 then
     373          until real1 < 10.0;
     374              real1 = real1 / 10.0;   exp1 = exp1 + 1;
     375          end until;
     376      elseif 0.0 < real1 & real1 < 1.0 then
     377          until real1 >= 1.0;
     378              real1 = real1 * 10.0;   exp1 = exp1 - 1;
     379          end until;
     380      end if;
     381
     382      $ round the result
     383      real1 = real1 + .5e-6;
smfb 162      if real1 >= 10.0 then real1 = real1 / 10.0; exp1 = exp1 + 1; end;
     384
     385      $ write leading digit and decimal point
     386      c = charofdig(ifix(real1));   l_call(write_char);
     387      c = 1r.;                      l_call(write_char);
     388
     389      $ write fraction and exponent
     390      if real1 < 1.0e-6 then
     391          c = 1r0;   l_call(write_char);
     392
     393      else
     394          $ write fraction
     395          do j = 1 to 6;
     396              real1 = (real1 - float(ifix(real1))) * 10.0;
     397              c = charofdig(ifix(real1));   l_call(write_char);
     398          end do;
     399
     400          $ write exponent
     401          c = 1re;   l_call(write_char);
     402
     403          if exp1 < 0 then c = 1r-; exp1 = - exp1; else c = 1r+; end;
     404          l_call(write_char);
     405
     406          int2 = exp1 / 10;
     407          c = charofdig(int2);   l_call(write_char);
     408          int1 = exp1 - int2 * 10;
     409          c = charofdig(int1);   l_call(write_char);
     410      end if;
     411
     412      go to rlab(ret_real) in 1 to zzya;
     413
     414
     415/write_int/                   $ local subroutine to write unsigned int
     416
     417      ret_int = retpt;
     418
     419      if int1 = 0 then
     420          c = 1r0;   l_call(write_char);
     421      else
     422          if int1 < 0 then
     423              c = 1r-;   l_call(write_char);
     424              int1 = -int1;
     425          end if;
     426          int2 = int1 / 10;   int3 = 1;
     427          while int2 > 0;
     428              int2 = int2 / 10;   int3 = int3 * 10;
     429          end while;
     430          while int3 > 0;
     431              c = charofdig(int1 / int3);   l_call(write_char);
     432              int1 = int1 - (int1 / int3) * int3;   int3 = int3 / 10;
     433          end while;
     434      end if;
     435
     436      go to rlab(ret_int) in 1 to zzya;
     437
     438
     439/write_char/                  $ local subroutine to write current char
     440
     441      .f. ofs1, chsiz, heap(ptr1) = c;   len = len + 1;
asca  92 .+ascebc if (ascebc_flag) .f. ofs1, chsiz, heap(ptr1) = aschar(c);
     442
     443      if ofs1 = chlst then    $ need to expand string block
     444          if p + lc_nwords(p) ^= h then
     445              $ the string must be copied to the top of the heap
     446              $ before the string block can be expanded
     447              ss_len(ss1) = len;   $ complete string specifier
     448              ss2 = nulllc(len);   $ allocate new string block
     449              mvc(ss2, ss1, len)   $ copy the string
     450              ss1 = ss2;
     451              p = ss_ptr(ss1);   ptr1 = p + icoffs(ss1, len);
     452              assert icorg(ss1, len) = chlst;
     453          end if;
     454          ofs1 = chorg;   ptr1 = ptr1 + 1;
     455          assert ss_ptr(ss1) = p;
     456          assert ss_ofs(ss1) = 0;
     457          assert p + lc_nwords(p) = h;
     458          assert lcalloc(len) = lc_nwords(p);
     459          get_heap(1, new);   $ get extra word
     460          lc_nwords(p) = lc_nwords(p) + 1;
     461      else                    $ update byte-in-word pointer
     462          ofs1 = ofs1 + chinc;
     463      end if;
     464
     465      go to rlab(retpt) in 1 to zzya;
     466
     467
     468      end fnct str;
       1 .=member valr
       2      fnct valr(arg);
       3
       4$ this routine converts a string representing a valid setl object to
       5$ its value. this is done by assigning the string to 'str_file' then
       6$ reading it.
       7
       8      size arg(hs);           $ specifier for string
       9
      10      size valr(hs);           $ specifier returned
      11
smfa  17      size ss1(ssz);          $ string specifier for argument
smfa  18
smfa  19$ little uses the following pre-defined string search sets:
smfa  20
smfa  21      +*  ss_blank   =  1b'00000001'  **  $ blank
smfa  22      +*  ss_separ   =  1b'00000010'  **  $ blank-equivalent separators
smfa  23      +*  ss_digit   =  1b'00000100'  **  $ digits 0..9
smfa  24      +*  ss_ucchar  =  1b'00001000'  **  $ upper case alphabetics a..z
smfa  25      +*  ss_lcchar  =  1b'00010000'  **  $ lower case alphabetics a..z
smfa  26      +*  ss_break   =  1b'00100000'  **  $ break character ('_')
smfa  27
smfa  28      size anyc(ws);          $ little string search primitive any.
smfa  29      size brkc(ws);          $ little string search primitive break.
      16
      17
smfa  30
smfa  31      ss1 = value_ arg;       $ get string specifier
      18      call err_fatal(49);
      19
      20
      21      end fnct valr;
       1 .=member sign
       2      fnct sign(arg);
       3
       4$ this is the setl sign function. it returns 0, 1, 0r -1
       5$ depending on the sign of its argument.
       6
       7      size arg(hs);  $ specifier for int or real
       8
       9      size sign(hs);  $ integer returned
      10
      11      size p(ps),     $ misc. pointer
      12           val(hs);   $ integer value
      13
      14      real val1;      $ real value
mjsa 778
mjsa 779      size ltli(1);
      15
      16      if type_ arg = t_real then
      17          p = value_ arg;
      18          val1 = rval(p);
      19
      20          if (val1 > 0.0) go to pos;
      21          if (val1 < 0.0) go to neg;
      22          go to zr;
      23
      24      else    $ must be an integer
mjsa 780          if (ltli(arg, zero)) go to neg;
mjsa 781          if (ltli(zero, arg)) go to pos;
mjsa 782          go to zr;
      30      end if;
      31
      32
      33/pos/       $ arg > 0. return 1.
      34
      35      sign = one;
      36      return;
      37
      38/neg/       $ arg < 0. return -1
      39
mjsa 783      sign = putintli(-1);
      44      return;
      45
      46/zr/        $ arg = 0. return 0
      47
      48      sign = zero;
      49      return;
      50
      51      end fnct sign;
       1 .=member sdate
       2      fnct sdate(dummy);
       3
       4$ this routine returns the current time and date as a setl string.
       5$ we simply call the little 'lstime' routine and convert its result
       6$ from an sds to a setl string.
       7
       8      size dummy(1);  $ dummy argument
       9
      10      size sdate(hs);  $ specifier for result
      11
      12      size str1(.sds. 30);  $ string built by little
      13
      14      size bldstr(hs);  $ converts sds to string
      15
      16      call lstime(str1);
      17      sdate = bldstr(str1);
      18
      19      return;
      20
      21      end fnct sdate;
       1 .=member sexp
       2      fnct sexp(arg1, arg2);
       3
       4$ this function computes -arg1 ** arg2-, where -arg1- and -arg2-
       5$ are specifiers.  we return a specifier for the result.
       6
       7
       8      size arg1(hs),          $ specifiers for inputs
       9           arg2(hs);
      10
      11      size sexp(hs);          $ specifier returned
      12
      13      size a1(hs),            $ local copies of arguments
      14           a2(hs);
      15
      16      size temp(hs);          $ temporary value
      17
      18      size val1(ps),          $ integer value of base
      19           val2(ps),          $ integer value of exponent
      20           val3(ps);          $ integer value of result
      21
      22      real v1,                $ real value of base
      23           v2,                $ real value of exponent
      24           v3;                $ real value of result
      25
      26      size multli(hs),        $ functions called
      27           divli(hs),
      28           modli(hs),
mjsa 784           floatli(hs),
mjsa 785           uminli(hs),
mjsa 786           ltli(hs),
mjsa 787           evenli(hs),
      29           err_val(hs);
      30
      31
      32      if is_om_ arg1 then     $ check arguments
      33          call err_om(22);
      34          go to error;
      35      end if;
      36
      37      if is_om_ arg2 then
      38          call err_om(23);
      39          go to error;
      40      end if;
      41
      42      a1 = arg1;   deref(a1)
      43      a2 = arg2;   deref(a2)
      44
      45      if type_ a1 = t_real then     $ get value of base
      46          v1 = rval(value_ a1);     $    real base
      47
      48      elseif type_ a1 = t_int ! type_ a1 = t_lint then
      49                                    $    integer base
      50          if type_ a2 ^= t_int & type_ a2 ^= t_lint then
      51              call err_type(53);    $      integer ** real undefined
      52              go to error;
      53          end if;
      54
mjsa 788          v1 = rval(value_ floatli(a1));
      57
      58      else
      59          call err_type(52);        $    invalid base
      60          go to error;
      61      end if;
      62
      63      if type_ a2 = t_real then     $ get value of exponent
      64          if (v1 <= 0.) go to error;$    real exponent:
      65                                    $      assert: v1 > 0.
      66          v2 = rval(value_ a2);     $      sexp := e ** (ln(v1) * v2)
      67          v3 = exp(alog(v1) * v2);
      68
      69          temp = v3;
      70          put_realval(temp, sexp);
      71
      72      elseif type_ a2 = t_int ! type_ a2 = t_lint then
mjsa 789          if (v1 = 0. & ltli(zero, a2) = no) go to error;
      76
mjsa 790          if otype_ a1 = t_real ! ltli(a2, zero)=yes then  $ real result
      78
mjsa 791              if ltli(a2, zero) then  $ compute (1./v1) ** (- a2)
mjsa 792                  v1 = 1. / v1; a2 = uminli(a2);
      82              end if;
      83
      84              v3 = 1.;
      85
      86              while 1;
mjsa 793                  if (evenli(a2) = no) v3 = v3 * v1;
mjsa 794                  a2 = divli(a2, two);
mjsa 795                  if (eq(a2, zero)) quit while 1;
      90                  v1 = v1 * v1;
      91              end while 1;
      92
      93              temp = v3;
      94              put_realval(temp, sexp);
      95
      96          else                      $       integer result
      97              sexp = one;
      98
      99              while 1;
mjsa 796                  if (evenli(a2) = no) sexp = multli(sexp, a1);
     101                  a2 = divli(a2, two);
mjsa 797                  if (eq(a2, zero)) quit while 1;
     103                  a1 = multli(a1, a1);
     104              end while 1;
     105
     106          end if;
     107
     108      else
     109          call err_type(53);        $    invalid exponent
     110          go to error;
     111      end if;
     112
     113      return;
     114
     115
     116/error/
     117
     118      sexp = err_val(f_gen);
     119
     120      return;
     121
     122
     123      end fnct sexp;
       1 .=member incs
       2      fnct incs(a1, a2);
       3
       4$ this function performs the setl -a1 incs a2- test. it returns
       5$ 0 or 1 depending on whether a1 includes a2.
       6
       7$ variable declarations
       8
       9      size a1(hs),            $ input specifiers
      10           a2(hs);
      11
      12      size incs(1);           $ boolean value returned
      13
      14      size p1(ps),            $ pointer to -a1-
      15           p2(ps);            $ pointer to -a2-
      16
      17      size e(hs),             $ specifier for set element
      18           iter(hs);          $ -e- in iterator format
      19
      20      size equal(1),          $ functions called
      21           memset(1);
      22
      23
      24$ check that both inputs are sets.
      25
      26      if ^ isset(otype_ a1) then
      27          call err_type(46);
      28          go to fail;
      29      end if;
      30
      31      if ^ isset(otype_ a2) then
      32          call err_type(47);
      33          go to fail;
      34      end if;
      35
      36$ compare the nelts of the two sets. there are three possibilities:
      37
      38$ 1. ? a1 = ? a2. then a1 incs a2 if and only if a1 = a2.
      39
      40$ 2. ? a1 > > a2. then a1 incs a2 iff every member of a2 is also
      41$    in a1.
      42
      43$ 3. otherwise return false.
      44
      45      ok_nelt(a1);            $ update nelt's
      46      ok_nelt(a2);
      47
      48      p1 = value_ a1;         $ get pointers to sets
      49      p2 = value_ a2;
      50
      51      if nelt(p1) = nelt(p2) then   $ return (a1 = a2)
      52          if (eq(a1, a2)) go to pass;
      53          if (equal(a1, a2)) go to pass;
      54          go to fail;
      55
      56      elseif nelt(p1) > nelt(p2) then   $ return (!e_a2 .st e_a1)
      57          call inext(e, iter, a2);
      58
      59          while 1;
      60              call nexts(e, iter, a2);
      61              if (is_om_ e) quit while;
      62
      63              if (^ memset(e, a1)) go to fail;
      64          end while;
      65
      66          go to pass;
      67
      68      else                    $ return .false
      69          go to fail;
      70
      71      end if;
      72
      73
      74/pass/
      75
      76      incs = yes;
      77
      78      return;
      79
      80
      81/fail/
      82
      83      incs = no;
      84
      85      return;
      86
      87
      88      end fnct incs;
       1 .=member pow
       2      fnct pow(s);
       3
       4$ this is the setl -pow s- operator.  it returns the powerset of -s-.
       5
       6$ to do so, it first creates a vector whose components are the
       7$ specifiers of the elements of -s-.  this way, the routine
       8$ -npow1- can index elements of -s- without having to search
       9$ through -s- every time.
      10
      11$ it then builds all the j-element subsets of s by repeatedly
      12$ calling -npow1-.
      13
      14
      15      size s(hs);             $ specifier of input set
      16
      17      size pow(hs);           $ specifier returned
      18
      19      size j(ps),             $ loop index
      20           n(ps),             $ loop limit
smfa  32           card(ps),          $ cardinality of result
      21           vect(hs),          $ specifier for vector with comps. of -s-
      22           p(ps);             $ pointer to -vect-
      23
      24      size nullset(hs),       $ functions called
      25           setform(hs),
      26           union(hs),
      27           initnpow(hs),
smfa  33           npow1(ps);
      29
      30
      31      if ^ isset(otype_ s) then   $ check argument
      32          call err_type(48);
      33          pow = err_val(f_uset);
      34          return;
      35      end if;
      36
      37      ok_nelt(s);             $ update nelt
      38
      39      vect = initnpow(s);     $ form a vector s.t. vect(i) _ s,
      40      p    = value_ vect;     $ get p to point to it,
      41      n    = nelt(p);         $ and get its cardinality.
      42
      43      pow = nullset(f_uset, 0);
      44      push1(pow);
smfa  34      card = 1;
      48
      49      do j = 1 to n;
smfa  35          card = card + npow1(vect, j);
      51      end do;
smfa  36
smfa  37      pow = setform(f_uset, card);
      52
      53
      54      end fnct pow;
       1 .=member npow
       2      fnct npow(arg1, arg2);
       3
       4$ this is the setl -arg1 npow arg2- operator.
       5
       6$ it returns the set of all k-element subsets of the set s.
       7
       8$ n.b.   we make no assumption as to which of the two arguments is
       9$        the specifier for the set, but assume the other argument
      10$        to be the specifier for the integer.
      11
      12
      13      size arg1(hs),          $ specifiers for inputs
      14           arg2(hs);
      15
      16      size npow(hs);          $ specifier returned
      17
      18      size a1(hs),            $ copies of arguments
      19           a2(hs);
      20
      21      size s(ps),             $ specifier for set
      22           k(hs),             $ value of -k-
smfa  38           card(ps),          $ cardinality of result
      23           vect(hs);          $ component vector of -s-
      24
      25      size nullset(hs),       $ functions called
      26           setform(hs),
      27           err_val(hs),
smfa  39           npow1(ps),
      29           initnpow(hs);
      30
      31
      32      a1 = arg1;              $ copy arguments
      33      a2 = arg2;
      34
      35      if ^ isset(otype_ a1) then   $ get -s- and -k-
      36          swap(a1, a2);
      37      end if;
      38
      39      if ^ isset(otype_ a1) then
      40          call err_type(49);
      41          npow = err_val(f_uset);
      42          return;
      43      end if;
      44
      45      s = a1;
      46      get_intval(k, a2);
      47
      48      ok_nelt(s);             $ update nelt of -s-
      49
      50      if k < 0 then           $ return .omega
      51          npow = err_val(f_uset);
smfa  40          return;
      52
smfa  41      elseif k > nelt(value_ s) then  $ return <>
smfa  42          card = 0;
      55
smfa  43      elseif k = 0 then       $ return << <> >>
      57          npow = nullset(f_uset, 0);
      58          push1(npow);
smfa  44          card = 1;
      60
      61      else
smfa  45          card = npow1(initnpow(s), k);
      64      end if;
smfa  46
smfa  47      npow = setform(f_uset, card);
      65
      66
      67      end fnct npow;
       1 .=member initnpow
       2      fnct initnpow(s);
       3
       4$ this function builds the component vector of -s-.
       5
       6$ a component vector is represented as a tuple whose components
       7$ are the specifiers of the elements of the set -s-.
       8
       9$ n.b.   we assume that the nelt of -s- is correct.  we can do
      10$        this because we know that -initnpow- is only called by
      11$        -pow- and -npow-, and that the nelt is correct at the
      12$        point of invocation.
      13
      14
      15      size s(hs);             $ specifier for input set
      16
      17      size initnpow(hs);      $ specifier returned
      18
      19      size e(hs),             $ specifier for element of -s-
      20           iter(hs),          $ -e- in iterator format
      21           p(ps),             $ pointer to vector
      22           j(ps);             $ loop index
      23
      24      size nulltup(hs);       $ function called
      25
      26
      27      initnpow = nulltup(f_tuple, nelt(value_ s));
      28      p        = value_ initnpow;
      29
      30      call inext(e, iter, s); $ initialize loop
      31      j = 0;
      32
      33      while 1;
      34          call nexts(e, iter, s);
      35          if (is_om_ e) quit;
      36
      37          j = j + 1;
      38          is_shared_ e = yes;   tcomp(p, j) = e;
      39      end while;
      40
      41      nelt(p) = j;            $ set proper nelt
      42
      43
      44      end fnct initnpow;
       1 .=member npow1
       2      fnct npow1(vect, k);
       3
       4$ this is the low level routine that builds -k- element
       5$ subset sets of the set -s-.  -s- is represented as a vector
       6$ -vect- whose components are the specifiers of -s-.
       7
       8$ we generate the subsets in lexicographic order of their
       9$ index in -vect-, using the following algorithm:
      10
smfa  48$ starting with the subset <>,
      12$ the next subset is found by scanning the control vector
      13$ -cvect- from right to left so as to locate the rightmost
      14$ element that has not yet attained its maximum value
smfa  49$ (max. value = # vect).  this element is incremented by one,
      16$ and all positions to the right are reset to the lowest
      17$ values possible.
      18
smfa  50$ n.b.   we assume that 1 <= k <= # vect.
smfa  51$        we return the cardinality of the result to the caller, and
smfa  52$        leave npow1 specifiers for the subsets on the stack.
      20
      21
      22      size vect(hs),          $ inputs
      23           k(ps);
      24
smfa  53      size npow1(ps);         $ specifier returned
      26
      27      size p(ps),             $ pointer to -vect-
      28           n(ps);             $ cardinality of -vect-
      29
      30      size cvect(hs),         $ control item
      31           c(ps);             $ pointer to -cvect-
      32
      33      size subset(hs);        $ spec for k-element subset of -s-
      34
      35      size i(ps),             $ inner loop index
      36           j(ps),             $ outer loop index
      37           count(ps);         $ number of k-element subsets
      38
      39      size nulltup(hs),       $ functions called
      40           setform(hs);
      41
      42
      43      p = value_ vect;        $ get pointer to component vector
      44      n = nelt(p);            $ and its cardinality
      45
      46      cvect = nulltup(f_ituple, k);   $ get control item
      47      c = value_ cvect;
      48      nelt(c) = k;
      49
      50      do i = 1 to k;          $ initialize control item
      51          tcomp(c, i) = i;
      52      end do;
      53
      54      count = 0;              $ initialize subset counter
      55
      56      while 1;
      57
      58          do i = 1 to k;      $ output subset
      59              push1(tcomp(p, tcomp(c, i)));
      60          end do;
      61
      62          subset = setform(f_uset, k);
      63          push1(subset);
      64          count = count + 1;
      65
      66          j = k;              $ update c for next combination
      67
      68          while tcomp(c, j) = n - k + j;
      69              j = j - 1;
      70          end while;
      71
      72          if (j = 0) quit while 1;
      73
      74          tcomp(c, j) = tcomp(c, j) + 1;
      75
      76          do i = j + 1 to k;
      77              tcomp(c, i) = tcomp(c, i-1) + 1;
      78          end do;
      79
      80      end while 1;
      81
smfa  54      npow1 = count;
      83
      84
      85      end fnct npow1;
       1 .=member grbcol
       2      subr grbcol;
       3
       4$ this is the top level routine of the garbage collector.  it calls
       5$ lower level routines to perform individual phases of garbage col-
       6$ lection and  monitors them to measure  their success.   based  on
       7$ these  measurements it will  continue execution,  attempt to  in-
       8$ crease the dynamic storage, or abnormally terminate execution  of
       9$ the program.
      10
      11$ general algorithm
      12
      13$ the garbage collector uses the 'lisp.2' garbage collection  algo-
      14$ rithm.   this algorithm makes the following assumptions about the
      15$ data structures:
      16$
      17$ 1. all pointers point to the start of a block.
      18$
      19$ 2. all blocks begin with the following standard fields:
      20$
      21$      htype:   a type code h_xxx identifying the type of the block
      22$      hlink:   a pointer field reserved for the garbage collector,
      23$               and left 'null' between garbage collections.
      24$
      25$ 3. on machines whose word size is greater than pointer size,  all
      26$    pointers except 'hlink' must appear in the same position with-
      27$    in a word.  this position is known as 'stdptr'.
      28$
      29$ 4. each dead block must have room for the following fields:
      30$
      31$      htype:   a type code h_xxx identifying the type of the block
      32$      hlink:   used as a pointer to the next live block
      33$      hsize:   the  size of  the  next series  of contigious  live
      34$               blocks
      35$
      36$ 5. certain special system values, constants, etc. are  considered
      37$    live throughout the  whole program.   thus there is  never any
      38$    need to  trace pointers  to  these objects or  pointers within
      39$    them.   these values are  stored in the low  core part of  the
      40$    heap, between heap(1) and heap(h_org).  all pointers into this
      41$    part of the heap are considered to be 'null',  and are ignored
      42$    by the garbage collector.  as a fringe benefit, this allows us
      43$    to store values into the 'hlink' field between garbage collec-
      44$    tions as long as we can assert that they are always less  than
      45$    'h_org', and thus appear 'null' when we interpret pointers.
      46$
      47$ 6. the interpretable code is  stored at the low order end of  the
      48$    heap, along with constants, etc.  there are generally no poin-
      49$    ters to these blocks, however, since they are in low core they
      50$    are not garbage collected.
      51
      52
      53$ the garbage collector is divided into four phases
      54
      55$    marking phase
      56$    adjustment phase
      57$    compaction phase
      58$    base compaction phase
      59
      60
      61$ marking phase
      62
      63$ during the marking phase we build a chain from each block to  all
      64$ words which contain pointers to it.  the list (called a 'hchain')
      65$ starts in the 'hlink' field of the block, and is threaded through
      66$ the 'stdptr' field of all words which originally  contained poin-
      67$ ters to the block.   at the end of the marking phase,  a block is
      68$ live if and only if its 'hlink' is non-null.
      69$
      70$ the marking routine  is called  twice.   the first time  it scans
      71$ starting from  the symbol table;   the second time  it scans from
      72$ the stack.   in each case,  it iterates over a series specifiers,
      73$ following long objects recursively.   each time a pointer is dis-
      74$ covered,  it is reversed and threaded into the glist of the block
      75$ it pointed to.
      76$
      77$ during the marking phase  we optionally perform the first step of
      78$ share bit compaction.   suppose 's' is a specifier  containing  a
      79$ pointer to a block 'b' which is located in the  collectable  part
      80$ of the heap.  as we process 's', we turn off its share bit.  when
      81$ we process 'b' during the adjustment phase,  we will be  able  to
      82$ whether it is actuall shared,  and set s's share bit accordingly.
      83$
      84$ since share bit compaction is very bug prone,  it is treated as a
      85$ special  conditional assembly option 'gs' (garbage-collect  share
      86$ bits)
      87
      88
      89$ adjustment phase
      90
      91$ during this phase  all pointers are  updated to their value after
      92$ the heap has been compacted.
      93$
      94$ the adjustment phase makes a linear pass through the heap,  star-
      95$ ting at  the first collectable location.   when we encounter each
      96$ block, we know:
      97$ 1. its type, which allows us to find its length.
      98$ 2. whether its live.
      99$ 3. the type(and hence the length) of all preceeding live blocks.
     100$ 4. the location of all pointers to the block that require adjust-
     101$    ment.
     102$
     103$ we iterate over the blocks hchain,  locate all words which origi-
     104$ nally contained pointers to the block, and reset them to point to
     105$ the next free word of storage.  after iterating over  the  chain,
     106$ we restore the original null pointer in the block's hlink  field,
     107$ since this may contain some useful information.
     108$
     109$ before  we adjust the pointers to each block we determine whether
     110$ the block is shared.   this is done  simply  by  checking  for an
     111$ hchain of length greater than one.
     112$
     113$ this information is used for two purposes.  first, it is used
     114$ in share bit compaction.  this is done as follows:
     115$
     116$ once we know that a block is shared, we may want to set the share
     117$ bits  of words pointing to it.   each block will fall into one of
     118$ three classes:
     119$
     120$ a. only specifiers contain pointers to the block
     121$ b. no specifiers contain pointers to the block
     122$ c. both specifiers and data words contain pointers to the block.
     123$
     124$ the class of a given block is determined by its htype.
     125$
     126$ if a block falls into class (a) we must set share bits of all
     127$ words containing pointers to it; if a block falls in class
     128$ (b) we must not.  if a block falls into class (c) it must be
     129$ an element block.  in this case there may be specifiers of
     130$ type element pointing to it.  however we do not care about
     131$ their share bits.
     132$
     133$ the following macro is true for htypes which fall into
     134$ class (a).  note that there are two forms of the macro, depending
     135$ on whether string specifiers are contained directly in specifiers.
     136
     137      +* is_spec_only(ht) =
     138          .f. ht, 1,
     139 .+ssi               4b'001fffef'
     140 .-ssi               4b'001fffff'  $ include long character strings
     141          **
     142
     143$ if a base eb is shared then it must have a specifier of type
     144$ element pointing to it.  this means that the eb is live, and
     145$ cannot be deleted during base compaction.  if we plan to do
     146$ base compaction, we indicate that the eb is live by clearing
     147$ its is_eblive bit.  this bit will be reset during base
     148$ compaction.
     149$
     150$ while we are scanning the heap, we use the dead words to construct
     151$ a chain linking the live blocks.  if p is a live block and q is
     152$ the word immediately following it, then either:
     153$
     154$ 1. q is also a live block:  in this case hlink(q) has been
     155$    restored to the original null value it had prior to garbage
     156$    collection.
     157$
     158$ 2. q is dead:  in this case we reuse hlink(q) to point to the
     159$    next live block and use hsize(q) to give the size of the next
     160$    live block(s).
     161
     162
     163$ compaction phase
     164
     165$ the compaction phase makes a linear scan through the heap, moving
     166$ each live block to its new position.  it keeps a pointer to the
     167$ next free location, and finds live blocks using the chain built
     168$ during the$ adjustment phase.
     169
     170
     171$ base compaction phase
     172
     173$ this phase removes dead element blocks from bases and optionally
     174$ recomputes base indices so that they are contiguous.  if it compacts
     175$ base indices it also compacts remote sets and maps to reflect the new
     176$ indices.  this phase potentially creates garbage which is removed
     177$ by the next the garbage collection.
     178$
     179$ an element block is considered dead if two conditions hold:
     180$
     181$ 1. no object of type 'element of'  points to it.   such a pointer is
     182$    indicated by the eb-s is_eblive bit being off.
     183$
     184$ 2. the element is not contained in any based set or in the domain of a
     185$    based map.
     186$
     187$ the base compaction phase begins by making a linear pass through
     188$ the heap, building a series of chains which drive the remainder
     189$ of the process.
     190$
     191$ the first chain, called -bchain- chains all bases together.  the list
     192$ starts at the global variable -bhead- and is threaded through the
     193$ -blink- field of each base.
     194$
     195$ the remaining chains, called -rchains- link each base to all the
     196$ remote sets and maps based on it.  these lists start at the -rhead-
     197$ field of each base and thread through the hashtb fields of the
     198$ remote objects(which will later be reset).
     199$
     200$ after the chains have been built, we iterate over bchain, compacting
     201$ one base at a time.
     202$
     203$ base compaction requires two temporary data structures which are
     204$ built on top of the heap.
     205$
     206$ the first data structure is a bit vector called 'live_vect'.
     207$ live_vect(i) is on if and only if the base element with
     208$ index i has been found to be live.
     209$
     210$ live_vect is represented as a standard remote set located at
     211$ heap(h).  this representation allows us to mark the live
     212$ elements of remote sets on a word by word basis.
     213$
     214$ the second data structure is called 'tot_live', and is used to
     215$ to perform the '.nb.' operation on live_vect.  tot_live(i) gives
     216$ number of 1-bits in the first i-1 words of live_vect.  the global
     217$ tot_org points to the zero-th component of tot_live.
     218$
     219$ on the cdc 6600 there is alot of extra room in each word of
     220$ a remote set.  we take advantage of this by packing
     221$ word of tot_live in with the corresponding word of live_vect.
     222$ as a result, tot_org is not necessary on the 6600.
     223$
     224$ the macros for these data structures are:
     225
     226      +* live_vect(i) =
     227          rsbit(h, i)
     228          **
     229
     230
     231      +* tot_live(i) =
suna  60 .+r32    heap(tot_org + i)
suna  61 .+r36    heap(tot_org + i)
     232 .+s66    .f. 33, 28, rsword(h, i)
     238          **
     239
     240
     241      +* nb(i) =  $ .nb. on live_vect(1:i)
     242
     243 .+s66.
     244          .f. 33, 28, heap(h + rsoffs(i)) +
     245          .nb. (.f. 1, rsorg(i), heap(h + rsoffs(i)))
     246 ..s66
suna  62
suna  63 .+r32.
     248          heap(tot_org + i/rs_bpw + 1) +
     249          .nb. (.f. 1, rsorg(i), heap(h + rsoffs(i)))
suna  64 ..r32
suna  65
suna  66 .+r36.
     260          heap(tot_org + i/rs_bpw + 1) +
     261          .nb. (.f. 1, rsorg(i), heap(h + rsoffs(i)))
suna  67 ..r36
     269
     270          **
     271
     272
     273
     274$ processing a base has five steps, each represented by a seperate
     275$ routine.  these steps are:
     276$
     277$ 1. set up live_vect and tot_live.  iterate over the
     278$    base determining which eb-s have live local objects defined
     279$    on them.
     280$
     281$ 2. iterate over the remote objects on the base, determining
     282$    which indices correspond to live eb-s.
     283$
     284$ 3. build tot_live, delete all dead eb-s from the base, and
     285$    assign new indices to the remaining eb-s.
     286$
     287$ 4. iterate over the remote objects, compacting each one.  this
     288$    is handled by two seperate routines.
     289$
     290$ 5. as we iterate over the remote objects, we reset their hashtb
     291$    fields.
     292
     293
     294$ after this, garbage collection is complete.  however garbage
     295$ collections are seldom fully effective; the process is monotonicly
     296$ convergent.  any one who has lasted this far is welcome to start
     297$ again.
     298
     299
     300      nameset nsgrbc;
     301
     302          size gitotal(ws),   $ instruction count at last garbage collec
     303               is_urgent(1),  $ flags emergency mode
     304               first_hole(ps); $ points to first dead block
     305
     306          size bchain(ps),    $ head of base chain
     307               old_maxi(ps),  $ maximum ebindx prior to compaction
     308               new_maxi(ps),  $ maximum ebindx after compaction
     314               bcwords(ps);   $ no. of words freed by base compaction
suna  68 .+r32    size tot_org(ps);   $ origin of tot_live.
suna  69 .+r36    size tot_org(ps);   $ origin of tot_live.
     315
     316          data gitotal = 0:
     317               is_urgent = no;
     318
     319          size has_base(1);   $ indicates whether the heap contains base
     320          data has_base = no; $  blocks:  if not, do not compact bases.
     321
     322      end nameset nsgrbc;
     323
     324
     325      size oldh(ps),          $ uncompacted value of h
     326          timeon(ws),         $ time at start of collection
     327          timeoff(ws),        $ time at end of collection
     328           j(ps);             $ loop index
     329
     330 .+gt.
     331      size currout(sds_sz),   $ name of current routine
     332           curstmt(ps);       $ current statement number
     333 ..gt
     334
     335      call letime(timeon);
     336
     337 .+s32u.
     338      if (vadvise&1)  call _vadvice(1);
     339 ..s32u
sunb  42 .+s68.
sunb  43      if (vadvise&1) call _vadvice(1);
sunb  44 ..s68
     340 .+gt.
     341      if gtrace then
     342          call find_stmt(currout, curstmt, codep);
     343
smfb 163          put ,skip
smfb 164              ,'garbage collection at instruction ' :codep,i
smfb 165              ,' at statement ' :currout,a ,'.' :curstmt,i ,skip;
     349
     350      end if gtrace;
     351 ..gt
     352
     353$ abort if the garbage collector has been disabled for an i/o
     354$ operation.
     355
     356      if (^ can_collect) call err_fatal(37);
     357
     358 .+st.
     359
     360$ reset cycle registers
     361
     362      do j = st_nubbin to st_copy;
     363          call icrput(j, 0);
     364      end do;
     365
     366      init_time(st_garb);
     367
     368 ..st
     369
     370      oldh = h;  $ save old top of heap
     371
     372$ reset t = savet, thus throwing away any junk left on the heap
     373$ by the library.
     374
     375      t = savet;
     376
     377$ see if we are calling the garbage collector twice in succession.
     378$ if so, request more space from the system and abort if none is
     379$ avaiable.
     380
     381$ note that we will eventually allow two garbage collections on the
     382$ same instruction, the second in an is_urgent mode which removes
     383$ breathing space from tuples, etc.
     384
     385      if itotal = gitotal + 1 then
     386          call getspace(h_lim + h_lim/10, yes);
     387          go to exit;
     388      end if;
     389
     390      gitotal = itotal;
     391
     392
     393$ first garbage collection
     394
     395      heap_valid = no;        $ mark pointers invlaid
     396
     397      grb_tot = grb_tot + 1; $ count garbage collections
     398      call grbmrk;            $ marking phase
     399      call grbadj;            $ adjustment phase
     400      call grbcmp;            $ compaction phase
     401
     402      heap_valid = yes;       $ pointers valid again
     403
     404      if (has_base) call gbcmp;   $ base compaction
     405
     406
     407$ second garbage collection
     408
     409$ if base compaction created enough garbage, do another collection.
     410$ we define 'enough' as a function of the space  recovered  by  the
     411$ garbage collection.
     412
     413      if bcwords > (oldh-h)/4 then
     414          heap_valid = no;
     415
     416          grb_tot = grb_tot + 1; $ count collections
     417          call grbmrk;
     418          call grbadj;
     419          call grbcmp;
     420
     421          heap_valid = yes;
     422      end if;
     423
     424      if float(oldh-h)/float(oldh) < 0.1 then
     425          call getspace(h_lim + h_lim/10, no);
     426      end if;
     427
     428
     429/exit/     $ collect statistics and terminate
     430
     431 .+st save_time(st_garb);
     432
     433$ we have saved the value of -h- at the start of the current setl
     434$ statement.  reset it.
     435
     436 .+st stmt_h = stmt_h - (oldh-h);
     437
     438 .+gt.  $ print statistics if desired
     439      if gtrace then
     440          put, 'recovered ': (oldh - h), i, ' words.', skip(2);
     441      end if gtrace;
     442 ..gt
     443
     444      grb_rec = grb_rec + (oldh-h); $ count words recovered
     445      call letime(timeoff);
     446      grb_tim = grb_tim + (timeoff-timeon);
     447
     448$ restart interpreter
     449
     450$ rather than returning to the point where the garbage collector
     451$ was invoked, we backtrack and reinvoke the interpreter.  since
     452$ this may involve an escape to assembly language, it is handled
     453$ by a special routine.
     454
     455 .+s32u.
     456      call _vadvice(0);
     457 ..s32u
sunb  45 .+s68.
sunb  46      call _vadvice(0);
sunb  47 ..s68
     458      call grbtrm;
     459
     460
     461      end subr grbcol;
       1 .=member grbmrk
       2      subr grbmrk;
       3
       4$ this is the first, or marking phase of the garbage collector.  it
       5$ scans all live pointers, setting up a chain (known as a 'hchain')
       6$ from each live block to each live word containing a pointer to it.
       7$ hchains start in the 'hlink' field of a block and thread through
       8$ the 'stdptr' fields of words which pointed to the block.
       9$
      10$ the routine has two parts.  the outer part iterates over the
      11$ symbol table and stack, while the inner part traces a single
      12$ specifier.
      13$
      14$ on entry to the recursive part of the routine, 'arg' points to the
      15$ specifier to be processed.
      16$
      17$ the recursive routine is unusual in that it does not increment the
      18$ stack immediately upon entry, but rather waits until it knows it
      19$ is necessary.  for this reason, there are two recursive exit
      20$ points, 'exit' which pops the stack as usual, and 'xexit' which
      21$ does not.
      22
      23
      24$ untyped data
      25
      26$ untyped data may appear in the stack and symbol table.  each
      27$ series of untyped heap words is preceded by a specifier
      28$ with:
      29$
      30$      type:       t_skip
      31$      value:      number of untyped words to be skipped.
      32
      33
      34$ utility macros
      35
      36$ since the garbage collector is quite complex, we provide
      37$ some macros to raise the semantic level of the code.
      38
      39      +* isnull(p) =          $ test for null pointer
      40          (p < sym_org ! (ca_org <= p & p < h_org))
      41          **
      42
      43
      44      +* reverse(word, block) =  $ reverse pointer from word to block
      45          stdptr(word) = hlink(block);
      46          hlink(block) = word;
      47          **
      48
      49
      50
      51
      52      size startp(ps);        $ starting point in symbol table/stack
      53
      54      size arg(ps);           $ argument to recursive routine
      55
      56      size b(ps);             $ temporary pointer to data block,
      57                              $ used before the stack has been
      58                              $ incremented
      59      size next_eb(ps);       $ pointer to next eb in list
      60      size base(ps);          $ pointer to base
      61      size ht(ps);            $ pointer to hash table
      62      size p(ps);             $ misc. pointer
      63      size first(1);          $ flags first pointer to block
      64
      65      access nsgrbc;
      66
      67
      68 .=zzyorg b      $ reset counter for stacked variables
      69
      70      local(retpt);           $ return pointer
      71      local(block);           $ current heap block
      72      local(j);               $ offset in current block
      73
      74
      75
      76 .+gt.
      77      if gdump then
      78          put, skip, column(7), '*** entering grbmrk ***', skip;
      79          call dumpds1;
      80      end if;
      81 ..gt
      82
      83
      84 .=zzyorg a                   $ reset counter for return labels
      85
      86      startp = sym_org;       $ start of symbol table
      87
      88
      89      while startp <= h_lim;
      90          assert (sym_org <= startp & startp <= sym_end) !
      91              (savet <= startp & startp <= h_lim);
      92
      93
      94          if type(startp) = t_skip then  $ skip untyped data
      95              startp = startp + value(startp);
      96              if (startp = sym_end + 1) startp = savet;
      97              cont while;
      98          end if;
      99
     100          arg = startp;       $ set paramater for recursive scan
     101
     102
     103      /entry/                 $ recursive entry point
     104          $
     105          $ at this point 'arg' points to the specifier to be
     106          $ processed.  we begin by checking whether it is short
     107          $ or contains a null pointer.  if so, we take an
     108          $ immediate exit.
     109          $
     110          if (isshort(type(arg))) go to xexit;
     111
     112 .+gt     if (gdump) call checkptr(arg, 0); $ check for validity
     113
     114          b = stdptr(arg);   if (isnull(b)) go to xexit;
     115          $
     116          $ at this point we know that the specifier contains a
     117          $ pointer to some block 'b' in the collectable part of
     118          $ the heap.  we check whether this is the first pointer
     119          $ to this block and build a back link.  if this is the
     120          $ first pointer to 'b', we scan it recursively.
     121          $
     122          first = isnull(hlink(b));   reverse(arg, b);
     123          if (^ first) go to xexit;
     124          $
     125          $ increment the recursion stack, save 'b' in the stacked
     126          $ variable 'block', and jump on its 'htype'.
     127          $
     128          t = t - ngarb_vars;   if (t < h) call err_fatal(38);
     129
     130          block = b;
     131
     132
     133          go to case(htype(block)) in h_min to h_max;
     134
     135
     136      /case(h_lint)/          $ types with no pointers
     137
     138      /case(h_real)/
     139
     140      /case(h_lstring)/
     141
     142          go to exit;
     143
     144
     145      /case(h_latom)/         $ long atom
     146
     147$ groups of long atoms are sometimes used to represent bases.  atoms
     148$ used in this fashion contain base information words for local
     149$ sets and maps.  we must trace the specifiers for the images of
     150$ typed local maps.
     151
     152$ in the following loop, block points to the long atom data block,
     153$ and j is an offset into the block for successive base information
     154$ words.  we loop from j = 1 to the number of local maps on the base,
     155$ marking the specifier for the image of each map.
     156
     157          j = 1;
     158
     159          while j <= la_nlmaps(block);
     160              arg = block + atomoffs(j);
     161              r_call;
     162              j = j+1;
     163          end while;
     164
     165          go to exit;
     166
     167
     168
     169      /case(h_tuple)/    $ standard tuple
     170
     171$ for tuples, we begin by marking the base array, then iterate
     172$ over the tuple, marking the specifier for each component.  j is
     173$ an index into the tuple.
     174
     175          j = 0;  $ index of current component
     176
     177          while j <= maxindx(block);
     178              arg = block + compoffs(j);
     179              r_call;
     180              j = j+1;
     181          end while;
     182
     183          go to exit;
     184
     185
     186      /case(h_ptuple)/        $ packed tuple
     187
     188$ mark the ptkey field and return
     189
     190          arg = block + off_ptkey;
     191          r_call;
     192
     193          go to exit;
     194
     195
     196      /case(h_ituple)/        $ untyped integer tuple
     197
     198      /case(h_rtuple)/        $ untyped real tuple
     199
     200$ these tuples never contain pointers into the live part of the
     201$ heap.  hence we can return immediately.
     202
     203          go to exit;
     204
     205
     206      /case(h_rmap)/    $ remote map
     207          $
     208          $ first reverse the hashtab field, then mark the embedded
     209          $ tuple.
     210          $
     211          ht = hashtb(block);   reverse(block + off_hashtb, ht);
     212          block = block + hl_rmap;
     213          go to case(h_tuple);
     214
     215
     216      /case(h_rpmap)/         $ remote packed map
     217          $
     218          $ first reverse the hashtab field, then mark the embedded
     219          $ packed tuple.
     220          $
     221          ht = hashtb(block);   reverse(block + off_hashtb, ht);
     222          block = block + hl_rpmap;
     223          go to case(h_ptuple);
     224
     225
     226      /case(h_lpmap)/         $ local packed map
     227          $
     228          $ trace ls_key, then treat like any other local map
     229          $
     230          arg = block + off_ls_key;
     231          r_call;
     232
     233
     234      /case(h_rset)/      $ based sets and maps
     235
     236      /case(h_rimap)/
     237
     238      /case(h_rrmap)/
     239
     240      /case(h_lset)/
     241
     242      /case(h_lmap)/
     243
     244      /case(h_limap)/
     245
     246      /case(h_lrmap)/
     247          $
     248          $ reverse pointer to hash table and  return.   note  that
     249          $ local objects based on plex bases will  always  have  a
     250          $ zero hashtb field.
     251          $
     252          ht = hashtb(block);
     253
     254          if ht ^= 0 then reverse(block + off_hashtb, ht); end if;
     255
     256          go to exit;
     257
     258
     259      /case(h_base)/
     260          $
     261          $ bases are processed in two steps:
     262          $
     263          $ 1. reverse the pointer to the hash table
     264          $
     265          $ 2. iterate over the element blocks.  for each eb, we
     266          $    perform the following two steps:
     267          $
     268          $    2.1 mark the element block specifier
     269          $    2.2 mark all local map images
     270          $
     271          ht = hashtb(block);   reverse(block + off_hashtb, ht);
     272
     273          block = ht + hl_ht;  $ point to template
     274
     275          until is_ebtemp(block);
     276              if is_ebtemp(block) ! ^ is_ebhedr(block) then
     277                  arg = block + off_ebspec;    $ mark specifier
     278                  r_call;
     279
     280                  j = 1;          $ index of current local map
     281                  while j <= ft_num(ebform(block), f_lmap);
     282                      arg = block + localoffs(j);  $ mark map image
     283                      r_call;
     284
     285                      j = j+1;
     286                  end while;
     287              end if;
     288
     289              next_eb = eblink(block);
     290              reverse(block + off_eblink, next_eb);
     291              block = next_eb;
     292          end until;
     293
     294          $ indicate that the heap contains bases
     295          has_base = yes;
     296
     297          go to exit;
     298
     299
     300
     301      /case(h_uset)/          $ unbased set
     302          $
     303          $ unbased sets are processed just like bases, except that
     304          $ the loop for processing their eb-s is somewhat simpler.
     305          $
     306          ht = hashtb(block);   reverse(block + off_hashtb, ht);
     307
     308          block = ht + hl_ht;  $ point to template
     309
     310          until is_ebtemp(block);
     311              if is_ebtemp(block) ! ^ is_ebhedr(block) then
     312                  arg = block + off_ebspec;  $ mark specifier
     313                  r_call;
     314              end if;
     315
     316              next_eb = eblink(block);
     317              reverse(block + off_eblink, next_eb);
     318              block = next_eb;
     319          end until;
     320
     321          go to exit;
     322
     323
     324      /case(h_umap)/          $ unbased map
     325          $
     326          $ this code is similar to the code for bases and  unbased
     327          $ sets.  here, however, we mark both the  eb's  specifier
     328          $ (ebspec) and the eb's image (ebimag).
     329          $
     330          ht = hashtb(block);   reverse(block + off_hashtb, ht);
     331
     332          block = ht + hl_ht;  $ point to template
     333
     334          until is_ebtemp(block);
     335              if is_ebtemp(block) ! ^ is_ebhedr(block) then
     336                  arg = block + off_ebspec;  $ mark domain specifier
     337                  r_call;
     338
     339                  arg = block + off_ebimag;  $ mark image specifier
     340                  r_call;
     341              end if;
     342
     343              next_eb = eblink(block);
     344              reverse(block + off_eblink, next_eb);
     345              block = next_eb;
     346          end until;
     347
     348          go to exit;
     349
     350
     351      /case(h_ebb)/           $ element base block
     352          $
     353          $ there is no need to process the element block now since
     354          $ we will process it as part of the base.
     355          $
     356          go to exit;
     357
     358
     359      /case(h_ebs)/           $ set element block
     360
     361      /case(h_ebm)/           $ map element block
     362          $
     363          $ we reach here when we are processing an internal
     364          $ variable used to iterate over an unbased set or
     365          $ map 's'.  there are three possibilities:
     366          $
     367          $ 1. we are still iterating over 's':  then we will
     368          $    process the element block as part of 's', so we
     369          $    merely branch to 'exit'.
     370          $
     371          $ 2. we have finished the loop, and 's' is still live:
     372          $    again, we will process the element block as part of
     373          $    's', and branch to 'exit'.
     374          $
     375          $ 3. we have finished the loop and redefined 's':  this
     376          $    means that the internal variable points to an element
     377          $    block which has become 'isolated' since the rest of
     378          $    the set is dead.
     379          $
     380          $    since we have finished the loop the internal variable
     381          $    will never be used again, and it is ok if it points
     382          $    to an element block which contains invalid pointers.
     383          $    once again, we simply branch to 'exit'.
     384          $
     385          go to exit;
     386
     387
     388      /case(h_ht)/            $ hash table header
     389          $
     390          $ hash table headers contain no pointers, so we take an
     391          $ immediate exit.
     392          $
     393          go to exit;
     394
     395
     396      /case(h_htb)/           $ hash table block
     397          $
     398          $ hash table blocks contain a pointer to either a clash
     399          $ list, or to the next hash table block.  there is no
     400          $ need to process this pointer here since it will be pro-
     401          $ cessed together with its base set, unbased set, or
     402          $ unbased map.
     403          $
     404          go to exit;
     405
     406
     407      /case(h_code)/          $ code
     408          $
     409          $ if we get here then either there is a code block in the
     410          $ collectable part of the heap, or we are tracing a null
     411          $ pointer.  this is very suspicious.
     412          $
     413          call err_fatal(45);
     414
     415
     416      /case(h_istring)/       $ indirect string specifier block
     417          $
     418          $ this type of block is only legal when the string
     419          $ specifier for long strings are stored as seperate
     420          $ data blocks.  this case is selected by the 'ssi'
     421          $ coditional assembly switch.
     422          $
     423          $ if we reach here and the 'ssi' switch is not set,
     424          $ then the heap is illformatted.
     425
     426 .+ssi.   $ strings stored indirectly
     427
     428          $ a string specifier contains one pointer to a long
     429          $ string data block:  mark it an return.
     430          $
     431          $ it would be faster to jump directly to the long string
     432          $ data block case.  however, this would require us to
     433          $ duplicate the code for reversing the pointer, testing
     434          $ it for null, etc.  some measurement should tell us
     435          $ whether it is worth it.
     436          $
     437          p = stdptr(block + off_ic_ptr);
     438          reverse(block + off_ic_ptr, p);
     439
     440          go to exit;
     441 ..ssi
     442
     443 .-ssi    call err_fatal(39);
     444
     445
     446
     447$ recursive exit points
     448
     449$ 'grbmrk' has two recursive entry points.   this reflects a little
     450$ 'cheating' at the recursive entry point: rather than incrementing
     451$ the stack immediaetely, we wait till we are sure that we actually
     452$ must scan recursively.  as a result it is not always necessary to
     453$ pop the stack on exit.
     454$
     455$ the exit point 'exit' pops the stack like  any  normal  recursive
     456$ exit point.   the label 'xexit' merges with the exit  code  after
     457$ stack has been popped.
     458
     459      /exit/        $ main exit point
     460
     461          t = t + ngarb_vars;  $ pop stack
     462
     463      /xexit/      $ exit here if stack wasnt incremented
     464
     465          if t ^= savet then  $ recursive return
     466              go to rlab(retpt) in 1 to zzya;
     467          end if;
     468
     469
     470          if startp = sym_end then
     471              startp = savet;
     472          else
     473              startp = startp + 1;
     474          end if;
     475
     476      end while;
     477
     478
     479      macdrop2(retpt, block);
     480      macdrop(j);
     481
     482      end subr grbmrk;
       1 .=member grbadj
       2      subr grbadj;
       3
       4$ this is the second, or adjustment phase of the garbage collector.
       5$ its main functions are to adjust all live pointers to  their  new
       6$ values,  and to build a chain linking all the  dead  blocks.   in
       7$ addition it resets all 'is_shared' bits and does some preperation
       8$ for base compaction.
       9$
      10$ each series of contigious live blocks is called a 'hole'.  at the
      11$ end of the adjustment phase each hole has the following structure:
      12$
      13$ hlink:  points to next live block
      14$
      15$ hsize:  gives the size of the series of live blocks immediately
      16$         following the hole.
      17$
      18$ each live block has its 'hlink' field restored to its original
      19$ live value.
      20$
      21$ although we make a single scan of the heap, it is probably
      22$ simplest to view the routine as performing two seperate
      23$ tasks.  one is adjusting pointers to live blocks, and the
      24$ other is building the chain between holes.
      25$
      26$ when we look at a block, we begin by testing whether it is
      27$ live.  a block is live if and only if its hlink is non-null.
      28$
      29$ live blocks are handled in three steps:
      30$
      31$ 1. we begin by determining if the block is shared, i.e.
      32$    if its hchain has length >= 2.  if so, we take a variety
      33$    of special actions.
      34$
      35$    first of all, we determine whether the block is pointed
      36$    to by specifiers.  if so, we must set the share bits of
      37$    all words pointing to the block.
      38$
      39$    second, if the block is a base eb and is shared, then
smfa  55$    it means there is a specifier of type element pointing to
      41$    it.  we turn on the blocks is_eblive bit to indicate that
      42$    the eb is live.
      43$
      44$ 2. next we iterate over the blocks hchain, finding all words
      45$    with pointers to the block, and reseting them to point to
      46$    the blocks new position.  at the end of this loop we
smfa  56$    restore the hlink field to its original null value.
      48$
      49$ 3. finally, if this is the first live block after a hole,
      50$    we place a pointer to it in the hlink of the hole.
      51$
      52$ when are only concerned with dead blocks if they are the start
      53$ of a hole.  in this case we take one of two actions:
      54$
      55$ 1. if this is the first hole, we save its location in 'first_hole'.
      56$
      57$ 2. otherwise 'hole' points to its previous hole.  we are now in
      58$    position to determine the number of live words between the
      59$    previous hole and the current one.  we store this in hsize(hole).
      60$
      61$ finally we determine the blocks length, and use it to find the
      62$ start of the next block.  if the block was live, we also advance
      63$ the pointer to the next word of free storage.
      64
      65
      66      access nsgrbc;
      67
      68      size block(ps);         $ pointer to current block
      69      size hole(ps);          $ pointer to most recent hole
      70      size free(ps);          $ pointer to first word of free space
      71      size len(ps);           $ size of current block
      72
      73      size doing_hole(1);     $ on when processing holes
      74
      75      size ht(ps);            $ htype of current block
      76      size set_share(1);      $ indicates that we should set share bits
      77      size p(ps);             $ pointer to word being adjusted
      78      size p1(ps);            $ extra pointer
      79
      80      size blksz(ps);         $ function called
      81
      82
      83 .+gt.
      84      if gdump then
      85          put, skip, column(7), '*** entering grbadj ***', skip;
      86          call dumpds1;
      87      end if;
      88 ..gt
      89
      90
      91      hole = 0;  $ indicate no holes found yet
      92      doing_hole = no;
      93
      94      block = h_org;  $ first collectable block
      95      free = block;          $ this is also the first possible free word
      96
      97
      98$ scan heap
      99
     100
     101      while block < h;
     102
     103          p = hlink(block);
     104
     105          if ^ isnull(p) then  $ block is live
     106              ht = htype(block);
     107
smfa  57$ see if block is shared and decide where to set share bits in the
     109$ the words pointing to it.
     110
     111              if isnull(stdptr(p)) then  $ only one ptr to block
     112 .+gs             set_share = no;
     113                  if (ht = h_ebb) is_eblive(block) = no;
     114
     115              else  $ block is shared
     116 .+gs             set_share = is_spec_only(ht);
     117                  if (ht = h_ebb) is_eblive(block) = yes;
     118              end if;
     119
     120$ adjust pointers and set share bits if necessary
     121
     122              until isnull(p);
     123                  p1 = stdptr(p);
     124                  stdptr(p) = free;
     125 .+gs             if (set_share) is_shared(p) = yes;
     126                  p = p1;
     127              end until;
     128
     129              hlink(block) = p;  $ restore original hlink
     130
     131$ if we were previously processing a hole, then we have found
     132$ the end of the hole.  in this case we must put a pointer to
     133$ the live block in the first word of the hole.
     134
     135              if doing_hole then
     136                  hlink(hole) = block;
     137                  doing_hole = no;
     138              end if;
     139
     140          else    $ dead block
     141
     142$ if this is the start of a new hole, we must reset 'hole' to
     143$ point to it.  if this is the first hole, then we also set
     144$ 'first_hole' to point to it.  otherwise we have already
     145$ found at least one hole.  in this case we have:
     146
     147$      hole  .... live block(s) .... new hole
     148
     149$ and we must save the length of the live block(s) in the first
     150$ word of the previous hole.
     151
     152              if ^ doing_hole then  $ start of new hole
     153
     154                  if hole = 0 then  $ first hole
     155                      first_hole = block;
     156                  else   $ save length of live block(s)
     157                      hsize(hole) = block - hlink(hole);
     158                  end if;
     159
     160                  hole = block;
     161              end if;
     162
     163              doing_hole = yes;
     164          end if;
     165
     166$ advance to the next block.  if this block is not part of a hole,
     167$ adjust 'free'.
     168
     169          len = blksz(block);
     170
     171 .+gt     if (len = 0) call err_fatal(40);
     172
     173          block = block + len;
     174          if (^ doing_hole) free = free + len;
     175
     176      end while;
     177
     178      h = free;   $ set -h- to first free location
     179
     180$ if there were no holes, set first_hole to zero.  otherwise if
     181$ the heap ended with a series of live blocks, we must put
     182$ the length of this series of blocks in the first word of the
     183$ last hole.
     184
     185      if hole = 0 then  $ no holes
     186          first_hole = 0;
     187      elseif ^ doing_hole then $ heap ends with live block
     188          hsize(hole) = block - hlink(hole);
     189      end if;
     190
     191
     192      end subr grbadj;
       1 .=member grbcmp
       2      subr grbcmp;
       3
       4$ this is the third, or compaction phase of the garbage collector.
       5$ it moves all live blocks towards the base of the heap.  the
       6$ adjustment phase hash threaded a list of live blocks through
       7$ the holes (dead blocks).
       8$
       9$ each hole has the following fields:
      10$
      11$     hlink: pointer to next series of contiguous live blocks
      12$     hsize: total lenght of these live blocks.
      13$
      14$ the global -first_hole- points to the first hole.
      15
      16
      17      access nsgrbc;
      18
      19      size hole(ps),  $ pointer to next hole in uncompacted heap
      20           free(ps),  $ pointer to next free word in compacted heap
      21           p(ps), $ pointer to block being moved
      22           plim(ps);  $ pointer to end of block
      23
      24
      25 .+gt.
      26      if gdump then
      27          put, skip, column(7), '*** entering grbcmp ***', skip;
      28          call dumpds1;
      29      end if;
      30 ..gt
      31
      32
      33      if (first_hole = 0) return;    $ no holes
      34
      35      hole = first_hole;
      36      free = hole;
      37
      38      while free ^= h;
      39
      40          p = hlink(hole);  $ find next live block
      41          plim = p + hsize(hole) -1;
      42
      43$ now move the block to its new location.  after moving it,
      44$ -free- will point to the word after the blocks new position,
      45$ and -hole- will point to the word after its old position,
      46$ which is the start of the next hole.
      47          while p <= plim;
      48              heap(free) = heap(p);
      49              p = p+1;
      50              free = free+1;
      51          end while;
      52
      53          hole = plim+1;   $ point to next hole.
      54      end while;
      55
      56
      57      end subr grbcmp;
       1 .=member gbcmp
       2      subr gbcmp;
       3
       4$ this is the final, or base compaction phase of the garbage
       5$ collector.  it processes one base at a time, first identifying
       6$ dead element blocks, and then deleting them and compacting
       7$ element block indices, followed by an update to all remote
       8$ objects.
       9
      10$ the storage allocation primitives always make sure that there
      11$ is enough between the stack and the heap to perform base
      12$ compaction.  the amount of space necessary is given by the
      13$ global 'min_gap' and is the minimum of:
      14$
      15$ 1. the space needed to compact the largest base.  this is given
      16$    by the macro gb_space(i), where i is the largest base index.
      17$
      18$ 2. the constant init_min_gap.
      19
      20$ we begin base compaction by setting min_gap to 0, since we
      21$ assert that there is enough space left.  while we iterate over
      22$ each base, we save the maximum eb index, and set min_gap at the
      23$ end accordingly.
      24
      25$ the global -bchain- is the head of a threaded list of bases.
      26
      27
      28      size base(ps);          $ current base
      29      size maxi(ps);          $ its maximum element block index
      30      size max_indx(ps);      $ maximum element block index
      31
      32      access nsgrbc;
      33
      34
      35 .+gt.
      36      if gdump then
      37          put, skip, column(7), '*** entering gbcmp ***', skip;
      38          call dumpds1;
      39      end if;
      40 ..gt
      41
      42
      43      call gbcmpc;            $ build base and remote chains
      44
      45      bcwords = 0;            $ initialize count of words freed
      46      min_gap = 0;            $ reset min_gap
      47
      48      $ go down base chain, calling lower routines to handle
      49      $ each phase of compaction on the current base.
      50
      51      while bchain ^= 0;
      52          base   = bchain;    $ get current base and advance
      53          bchain = blink(base);
      54
      55          $ phase 1: mark all eb-s in the base whose specifiers
      56          $          are elements of a local set or elements of
      57          $          the domain of a local map.  marking is done
      58          $          by clearing the is_eblive flag of the eb.
      59          call gbcmp1(base);
      60
      61          $ phase 2: mark all remaining eb-s which are not
      62          $          elements of a remote set or the domain of
      63          $          a remote map.
      64          call gbcmp2(base);
      65
      66          $ phase 3: delete the dead eb-s and set is_eblive on the
      67          $          remaining ones.
      68          call gbcmp3(base);
      69
      70          $ phase 4: compact indices
      71          call gbcmp4(base);
      72
      73          $ update max_indx, the maximum eb-index found
      74          maxi = ebindx(template(base)) - 1;
      75          if (max_indx < maxi) max_indx = maxi;
      76      end while;
      77
      78      min_gap = gb_space(max_indx);
      79      if (min_gap < init_min_gap) min_gap = init_min_gap;
      80
      81
      82      end subr gbcmp;
       1 .=member gbcmpc
       2      subr gbcmpc;
       3
       4$ this routine is called at the start of the base compaction phase to
       5$ build the base chain and various rchains.  at this point the garbage
       6$ collector has removed all dead bases and based objects.  as a result,
       7$ we need only make a linear scan of the heap to build the chains.
       8
       9
      10      access nsgrbc;
      11
      12      size block(ps), $ pointer to current block
      13           len(ps),  $ length of block
      14           bform(ps),  $ form of base
      15           base(ps);  $ pointer to base
      16
      17      size blksz(ps); $ function called
      18
      19
      20      bchain = 0;   $ initialize base chain.
      21
      22      block = h_org;  $ first collectable block
      23
      24      while block < h;  $ scan heap
      25
      26          if is_remote(htype(block)) then $ add to rchain.
      27              bform = ft_base(hform(block));
      28              base  = value(ft_samp(bform));
      29
      30              hashtb(block) = rlink(base);
      31              rlink(base) = block;
      32
      33          elseif htype(block) = h_base then $ add to bchain
      34              blink(block) = bchain;
      35              bchain = block;
      36          end if;
      37
      38          block = block + blksz(block);
      39
      40      end while;
      41
      42
      43      end subr gbcmpc;
       1 .=member gbcmp1
       2      subr gbcmp1(b);
       3
       4$ this routine performs the first phase of base compaction on the
       5$ base b.  this is done in two steps:
       6
       7$ 1. format the block on top of the heap into an appropriate
       8$    null bit string.
       9
      10$ 2. iterate over the elements of the base, setting the
      11$    corresponding bit of live_vect if the block
      12$    is found to be live.  this is done through three series of
      13$    tests:
      14
      15$    a. if the blocks is_eblive bit is off, there is a specifier
      16$       of type element pointing to it, so the block is live.  at
      17$       this point we also reset the is_eblive flag.
      18
      19$    b. iterate over the typed local map images.  if any of these
      20$       are defined, the block is live.
      21
      22$    c. test the remaining base information words.  the block is
      23$       live if they do not match the corresponding word of the
      24$       template.
      25
      26
      27      access nsgrbc;
      28
      29      size b(ps);    $ pointer to base
      30
      31      size tmp(ps),    $ pointer to template block
      32           eb(ps),  $ pointer to current eb
      33           indx(ps),   $ its ebindx
      34           ebsz(ps),   $ ebsize of base
      35           nlm(ps);    $ nlmaps of base
      36
      37      size j(ps),   $ loop index
      38           p(ps);   $ pointer to range set
      39
      40      size nullp(1);  $ function called
      41
      42
      43$ begin by getting various statistics about the base and initializing
      44$ live_vect to nulb.
      45
      46$ the numbers we need are:
      47
      48$ tmp:   pointer to template
      49$ nlm:   number of typed local maps
      50$ ebsz:  ebsize of base
      51
      52      tmp = template(b);
      53      nlm = nlmaps(b);
      54
      55      ebsz = ebsize(tmp);
      56
      57$ initialize live_vect and tot_live.  we initialize live_vect by
      58$ setting its 'rs_maxi' then zeroing its bit string.
      59
      60$ rs_maxi must be at least the maximum ebindx of the base.  as usual
      61$ for remote sets it must also be one less than a multiple of
      62$ rs_bpw.  if k is the floor of the maximum index/rs_bpw, this
      63$ comes to k * rs_bpw + (rs_bpw-1).
      64
      65      rs_maxi(h) = ((ebindx(tmp)-1)/rs_bpw)*rs_bpw + (rs_bpw-1);
      66
      67      do j = 1 to rswords(h);
      68          rsword(h, j) = 0;
      69      end do;
      70
      71$ if we are not packing 'tot_live' in with live_vect, we must
      72$ set tot_org to point to the last word of live_vect.
      73 .-s66 tot_org = h + hl_rset + rswords(h) - 1;
      74
      75
      76$ iterate over eb-s
      77
      78$ we use a next loop to iterate over the eb-s.  this loop skips dummy
      79$ hash headers, but this is all right since they dont have eb-indices
      80$ anyway.
      81
      82
      83      next_loop(eb, b);
      84$ get the elements indexand see if there are specifiers pointing to it
      85          indx = ebindx(eb);
      86
      87          if is_eblive(eb) then  $ specifiers point to it
      88              is_eblive(eb) = no;
      89              live_vect(indx) = yes;
      90              cont;
      91          end if;
      92
      93$ otherwise check the specifiers for typed local maps.
      94
      95          do j = localoffs(1) to localoffs(nlm);
      96
      97              if is_multi(tmp+j) then  $ check for null range set
      98                  p = value(eb+j);
      99
     100                  if (p = value(tmp+j)) cont;  $ matches template
     101
     102                  if is_neltok(p) then
     103                      if (nelt(p) = 0) cont;
     104                  else
     105                      if (nullp(p)) cont;
     106                  end if;
     107
     108              else      $ see if is_om bit is set
     109                  if (is_om(eb+j)) cont;
     110              end if;
     111
     112$ if we reach here the block is live.  mark it and go to the next eb.
     113              live_vect(indx) = yes;
     114              cont_next;
     115          end do;
     116$ if there are no defined maps, check local sets and untyped maps
     117
     118          do j = localoffs(nlm)+1 to ebsz-1;
     119
     120              if heap(eb+j) ^= heap(tmp+j) then $ live
     121                  live_vect(indx) = yes;
     122                  cont_next;
     123              end if;
     124
     125          end do;
     126
     127      end_next;
     128
     129
     130      end subr gbcmp1;
       1 .=member gbcmp2
       2      subr gbcmp2(b);
       3
       4$ this is the second phase of base compaction.  it clears the is_eblive
       5$ flag of each element block of -b- which is an element of a remote set
       6$ or of a remote map.
       7
       8$ the -rlink- field of -b- contains the head of a list of remote objects
       9$ on b; the list is threaded through the hashtb field of each remote
      10$ object.
      11
      12$ we iterate over the list of remote objects, jumping on the type
      13$ we then iterate over the objects tuple or bit string.  if the
      14$ object is defined for the index -i-, we set the i-th bit of the
      15$ live_vect.
      16
      17
      18      access nsgrbc;
      19
      20      size b(ps);   $ pointer to base
      21
      22      size rset(ps);  $ pointer to remote set
      23
      24      size tup(ps),  $ pointer to tuple or bit string
      25           j(ps),    $ loop index
      26           sample(ps),  $ pointer to sample range set
      27           p(ps),       $ pointer to range set
      28           om_val(hs);   $ untyped om
      29
      30      size nullp(1);   $ function called
      31
      32
      33      rset = rlink(b);   $ point to first remote set or map
      34
      35      while rset ^= 0;   $ process all remote sets
      36
      37          go to case(htype(rset)) in h_rset to h_rrmap;
      38
      39
      40      /case(h_rset)/     $ remote set
      41
      42                         $ iterate over bit string, looking for on bits.
      43$ iterate over bit string a word at a time, or-ing in each word
      44$ with the corresponding word of live_vect.
      45
      46          do j = 1 to rswords(h);
      47              rsword(h, j) = rsword(h, j) ! rsword(rset, j);
      48          end do;
      49
      50
      51          go to esac;
      52
      53
      54      /case(h_rmap)/    $ remote map
      55
      56          tup = rset + hl_rmap;  $ get pointer to tuple
      57
      58          if (is_mmap(rset)) go to mmap; $ mmaps are treated specially
      59
      60          do j = 1 to maxindx(tup);     $ look for defined components
      61              if (^ is_om_ tcomp(tup, j)) live_vect(j) = yes;
      62          end do;
      63
      64          go to esac;
      65
      66
      67      /mmap/            $ remote mmaps
      68
      69               $ for mmaps, we check not for om components,
      70               $ but for components whose range set is nl.
      71
      72          sample = value_ tcomp(tup, 0);  $ get sample range set
      73
      74          do j = 1 to maxindx(tup);
      75              p = value_ tcomp(tup, j);   $ get pointer to range set
      76
      77              if (p = sample) cont;    $ must be null
      78
      79              if is_neltok(p) then
      80                  if (nelt(p) = 0) cont;
      81              else
      82                  if (nullp(p)) cont;
      83              end if;
      84                                  $ map defined at this point
      85              live_vect(j) = yes;
      86          end do;
      87
      88
      89          go to esac;
      90
      91
      92      /case(h_rpmap)/         $ remote packed map
      93
      94      $ an image is defined if its non-zero.  the loop which follows
      95      $ allows alot of room for strength reduction someday.
      96
      97
      98          tup = rset + hl_rpmap;  $ get pointer to tuple
      99          do j = 1 to maxindx(tup);
     100              if (pcomp(tup, j) ^= 0) live_vect(j) = yes;
     101          end do;
     102
     103          go to esac;
     104
     105
     106      /case(h_rimap)/        $ remote integer and real maps
     107
     108          tup = rset + hl_rmap;  $ get pointer to tuple
     109
     110          do j = 1 to maxindx(tup);
     111              if (tcomp(tup, j) ^= om_int) live_vect(j) = yes;
     112          end do;
     113
     114          go to esac;
     115
     116
     117      /case(h_rrmap)/
     118
     119          tup = rset + hl_rmap;  $ get pointer to tuple
     120
     121          do j = 1 to maxindx(tup);
     122              if (tcomp(tup, j) ^= om_real) live_vect(j) = yes;
     123          end do;
     124
     125          go to esac;
     126
     127
     128      /esac/   $ end of case
     129
     130          rset = hashtb(rset);     $ get next remote set
     131
     132      end while;
     133
     134
     135      end subr gbcmp2;
       1 .=member gbcmp3
       2      subr gbcmp3(b);
       3
       4$ this routine deletes all dead element blocks from the base b.
       5$ the routine is driven by live_vect.  this is a
       6$ bit vector whose i-th bit is on if and only if the element
       7$ with base index i is live.
       8
       9$ the calls to the delete routine do not automaticall rehash
      10$ the base.  instead, we rehash it after we are done iterating
      11$ over it.
      12
      13
      14      access nsgrbc;
      15
      16      size b(ps);  $ pointer to base
      17
      18      size eb(ps),  $ pointer to current eb
      19           prev(ps),  $ pointer to previous eb
      20           ebsz(ps);  $ ebsize of base
      21
      22
      23      prev = 0;     $ pointer to previous eb
      24      ebsz = ebsize(template(b));  $ save ebsize
      25
      26      next_loop(eb, b);
      27
      28          if live_vect(ebindx(eb)) = no then  $ dead block
      29              call delete(b, prev, eb, no);
      30              bcwords = bcwords + ebsz;  $ indicate space freed
      31          else      $ live block
      32              is_eblive(eb) = yes;   $ reset flag
      33              prev = eb;
      34          end if;
      35
      36      end_next;
      37
      38      maycontract(b);         $ rehash base if neccessary
      39
      40
      41      end subr gbcmp3;
       1 .=member gbcmp4
       2      subr gbcmp4(b);
       3
       4$ this is the final phase of the garbage collector(thought it would
       5$ never end, didn-t you).  at this point all the dead elements of
       6$ -b- have been deleted.  if enough elements have been deleted, we
       7$ compact base indices and remote objects.  in any case, we reverse
       8$ the chain from -b- to its remote sets and maps, so that their
       9$ hashtb fields all point to b-s hash table.
      10
      11$ we map each old index i into a new index by taking the total
      12$ number of live indices between 1 and i, inclusive.  this is
      13$ equivlent to applying the little .nb. operator to a substring
      14$ of live_vect, and is done by the macro 'nb'.
      15
      16
      17      access nsgrbc;
      18
      19      size b(ps);  $ pointer to base
      20
      21      size i(ps),  $ loop index
      22           newi(ps),  $ next available compacted index
      23           eb(ps), $ pointer to eb
      24           ht(ps), $ pointer to bases hash table
      25           p(ps),  $ pointer to set/map
      26           nxt(ps),  $ pointer to next remote set/map on chain
      27           compact(1);  $ on if compacting indices
      28
      29
      30$ compact if the maximum ebindx is greater than twice the number of eb-s
      31      compact = ebindx(template(b)) > (2 * neb(hashtb(b)));
      32
      33$ if we plan to compact, we must rebuild the index map and reset the
      34$ ebindx fields of the eb-s.
      35
      36      if compact then   $ adjust index map
      37
      38$ set old_maxi and new_maxi to the maximum base index before and
      39$ after base compaction.
      40          old_maxi = ebindx(template(b))-1;
      41          new_maxi = neb(hashtb(b));  $ maximum is number of ebs
      42
      43
      44$ build tot_live.  tot_live(i) is the total number of 1-bits in
      45$ words 1 to i-1 of live_vect.
      46
      47          tot_live(1) = 0;
      48
      49          do i = 2 to rswords(h);
      50              tot_live(i) = tot_live(i-1) +
      51                            .nb. (.f. 1, rs_bpw, rsword(h, i-1));
      52          end do;
      53
      54          $ adjust indices in eb-s.
      55          next_loop(eb, b);
      56              ebindx(eb) = nb(ebindx(eb));
      57          end_next;
      58
      59          $ adjust ebindx in template
      60          ebindx(template(b)) = new_maxi + 1;
      61      end if;
      62
      63
      64
      65      $ go down list of remote maps, resetting hashtb pointers and
      66      $ compacting if desired.
      67
      68      ht = hashtb(b);  $ point to hash table of base
      69      p  = rlink(b); $ first remote object
      70
      71      rlink(b) = 0;  $ reinitialize
      72
      73      while p ^= 0;
      74
      75          nxt = hashtb(p);    $ next remote object
      76
      77          hashtb(p) = ht;                 $ reset hashtb
      78          if (compact) call gbcmp5(p);   $ compact
      79
      80          p = nxt;
      81      end while;
      82
      83
      84      end subr gbcmp4;
       1 .=member gbcmp5
       2      subr gbcmp5(rset);
       3
       4$ this routine is called from 'gbcmp4' to compact a single  remote
       5$ set or map.  at this point there is a vector on top of the stack
       6$ which maps each element block index into its compacted index (or
       7$ zero, if the corresponding element is not defined).   we iterate
       8$ over the remote object, and update its components.
       9
      10
      11      access nsgrbc;
      12
      13      size rset(ps);          $ pointer to remote set/map
      14
      15      size j(ps),             $ loop index
      16           tup(ps),           $ pointer to tuple or bit string
      17           comp(hs),          $ set/map component
      18           om_val(hs);        $ untyped om
      19
      20
      21      go to case(htype(rset)) in h_rset to h_rrmap;
      22
      23
      24/case(h_rset)/                $ remote set
      25
      26      do j = 1 to rs_maxi(rset);
      27          comp = rsbit(rset, j);   rsbit(rset, j) = no;
      28
      29          if (comp = yes) rsbit(rset, nb(j)) = yes;
      30      end do;
      31
      32      return;
      33
      34
      35/case(h_rpmap)/               $ remote packed map
      36
      37      tup = rset + hl_rpmap;
      38
      39      do j = 1 to maxindx(tup);
      40          comp = pcomp(tup, j);   pcomp(tup, j) = 0;
      41
      42          if (comp ^= 0) pcomp(tup, nb(j)) = comp;
      43      end do;
      44
      45      return;
      46
      47
      48/case(h_rmap)/                $ remote map
      49
      50/case(h_rimap)/               $ remote integer map
      51
      52/case(h_rrmap)/               $ remote real map
      53
      54      tup = rset + hl(htype(rset)); $ pointer to embedded tuple
      55      om_val = tcomp(tup, 0);       $ proper omega
      56
      57      do j = 1 to maxindx(tup);
      58          comp = tcomp(tup, j);   tcomp(tup, j) = om_val;
      59
      60          if (comp ^= om_val) tcomp(tup, nb(j)) = comp;
      61      end do;
      62
      63      return;
      64
      65
      66      end subr gbcmp5;
       1 .=member grbtrm
       2      subr grbtrm;
       3
       4$ this is the termination routine for the garbage collector.  the
       5$ garbage collector never executes a return.  instead it calls
       6$ the interpreter, which repeats the operation which called the
       7$ garbage collector.
       8
       9$ this type of recursive call is not defined in little and may
      10$ have to be made with the help of assembly language.  the
      11$ version written in little will work on the cdc 6600 and
      12$ the ibm 370, but not on the pdp10 or pdp11.
      13
      14$ if we are compiling trace code using the little monitor
      15$ package we must clear some of little's internal tables.
      16
      17$ this is done by accessing the nameset in ltllib which
      18$ contains the global variables for the monitor package.
      19
      20 .+gt.
      21
      22$ we call a special little routine to reinitialize the little
      23$ debugging package.
      24
      25      call 7nsubn$mp('', 0);
      26
      27 ..gt
      28
      29
      30      call envrsi;            $ restart setl interpreter
      31
      32      end subr grbtrm;
       1 .=member envrsi
       2 .-defenv_envrsi.
       3
       4
       5 .+s37.
       6
       7      subr envrsi;
       8
       9$ 'envrsi' restarts the setl interpreter.  the default implementation
      10$ is just to call the interpreter.
      11
      12$ systems which use a separate stack for procedure calls will need
      13$ to implement this procedure in the environment to clean up the
      14$ stack.
      15
      16
      17      call interp;
      18
      19
      20      end subr envrsi;
      21
      22 ..s37
      23
      24
      25 .+s47.
      26
      27      subr envrsi;
      28
      29$ 'envrsi' restarts the setl interpreter.  the default implementation
      30$ is just to call the interpreter.
      31
      32$ systems which use a separate stack for procedure calls will need
      33$ to implement this procedure in the environment to clean up the
      34$ stack.
      35
      36
      37      call interp;
      38
      39
      40      end subr envrsi;
      41
      42 ..s47
      43
      44
      45 .+s66.
      46
      47      subr envrsi;
      48
      49$ 'envrsi' restarts the setl interpreter.  the default implementation
      50$ is just to call the interpreter.
      51
      52$ systems which use a separate stack for procedure calls will need
      53$ to implement this procedure in the environment to clean up the
      54$ stack.
      55
      56
      57      call interp;
      58
      59
      60      end subr envrsi;
      61
      62 ..s66
      63
      64 ..defenv_envrsi
      65
      66
       1 .=member getspace
       2      subr getspace(lim, abt);
       3
       4$ this routine is called to request more space from the operating
       5$ system. its parameters are:
       6
       7
       8      size lim(ps),           $ new dimension for heap
       9           abt(1);            $ indicates abort if out of space
      10
      11
      12$
      13$ we first try to get more space from the operating system, seeking to
      14$ increase the heap to lim words.  if we cannot increase the heap to
      15$ lim words, we either abort (if abt is true) or return what we got (if
      16$ abt is false).  in the latter case, we move the stack towards high
      17$ core before we return, adjusting pointers in environment blocks.
      18$
      19$ on exit, h_lim gives the new dimension of the heap.
      20
      21$ if 'lim' is less than or equal to the current heap dimension
      22$ we merely set h_lim and return.
      23
      24$ the first time getspace is called the heap is empty and there is
      25$ no need to adjust symbol table pointers, etc.
      26
      27      size cur_lim(ws),       $ current dimension
      28           max_lim(ws),       $ maximum dimension allowed on users accou
      29           new_lim(ws);       $ new limit
      30
      31      size init(1);           $ indicates first call
      32      data init = yes;
      33
      34      size adj(1);            $ on if code must be adjusted
      35
      36      size p(ps),             $ pointer to current block
      37           j(ps);             $ loop index
      38      size nxt(ps);           $ pointer to next environment block
      39
      40      size bias(ps);          $ bias for code arguments
      41
      42      size fc(ws),            $ function code
      43           bfr(ws);           $ return code
      44
      45      size p1(ws),            $ parameters to memory request
      46           p2(ws);
      47
      48
      49
      50      if init then            $ first call
      51          init = no;
      52          adj  = no;
      53      else
      54          adj = yes;
      55      end if;
      56
      57$ get values for cur_lim and max_lim
      58
      59      call envmhl(1, cur_lim, max_lim);
      60
      61      if (lim <= cur_lim) return;
      62
      63      if lim > max_lim then
      64          if (abt) call err_fatal(41);
      65          lim = max_lim;
      66      end if;
      67
      68$ otherwise get additional space
      69
      70      p1 = lim;   p2 = max_lim;
      71
      72      call envmhl(2, p1, p2); $ increment heap length
      73
      74      new_lim = p1;
      75      if (new_lim < lim & abt) call err_fatal(41);
      76
      77$ if the heap is empty, merely set h_lim = lim and return.
      78$ at this point we may have new_lim > lim.  however, since we are
      79$ not readjusting pointers, we ignore the extra space.
      80
      81      if adj = no then
      82          h_lim = lim;
      83          return;
      84      end if;
      85
      86$ reset 'h_lim' to the actual heap size and move the stack.
      87
      88      bias = new_lim - h_lim;
      89
      90 .+gt.
      91      if gtrace then
      92          put, 'expanded heap by ':    bias, i, ' words.  ',
      93               'new heap size = ':  new_lim, i, ' words.  ',
      94               skip;
      95      end if;
      96 ..gt
      97
      98      do j = h_lim to t by -1;
      99          heap(j+bias) = heap(j);
     100      end do;
     101
     102      h_lim   = h_lim   + bias;
     103      t       = t       + bias;
     104      savet   = savet   + bias;
     105
     106
     107$ adjust the list of saved environment blocks threaded through the stack
     108
     109      if (last_env = 0) return; $ no saved environments
     110
     111      last_env = last_env + bias;
     112      p        = last_env;
     113
     114      while value(p+1) ^= 0;
     115          nxt        = value(p+1);
     116          value(p+1) = value(p+1) + bias;
     117          p          = nxt;
     118      end while;
     119
     120
     121      end subr getspace;
       1 .=member envmhl
       2
       3
       4
       5 .+mhl_static.
       6
       7      subr envmhl(fc, p1, p2); $ manage heap length from static array
       8
       9$ this version of 'envmhl' does not allocate the heap but
      10$ assumes that allocation beyond that provided by declaration as
      11$ little array is done elsewhere.  the procedure assumes that
      12$ 'heap_dims' contains maximum length and then allocates from
      13$ within this range.
      14$ this implementation currently used for s10, s37 and s47 versions.
      15
      16
      17$ 'fc' is a function code with the following interpretation:
      18
      19$ fc=1:    set 'p1' to the current heap length, and 'p2' to the
      20$          maximum permitted heap length.
      21
      22$ fc=2:    set heap length to 'p1', and return change in heap
      23$          length in 'p2'.
      24
      25
      26      size  fc(ps),           $ function code
      27            newl(ws),         $ new heap length
      28            p1(ws),           $ first parameter
      29            p2(ws);           $ second parameter
      30      size  init(1); data init = yes;
      31
      32
      33 $ guarantee that cur_heap_dim initially zero
      34      if init then
      35          init = no;
      36          cur_heap_dim = 0;
      37          max_heap_dim = heap_dims;
      38      end if;
      39
      40
      41      if fc = 1 then          $ return current and maximum lengths
      42          p1 = cur_heap_dim;
      43          p2 = max_heap_dim;
      44
      45      elseif fc = 2 then      $ set length
      46          newl = p1;
      47          if (newl > max_heap_dim) newl = max_heap_dim;
      48
      49          p1 = newl;          $ new length
      50          p2 = newl - cur_heap_dim; $ change
      51          cur_heap_dim = newl;
      52
      53      end if;
      54
      55
      56      end subr envmhl;
      57 ..mhl_static
      58
      59
      60
      61 .+mhl_dynamic.
      62      subr envmhl(fc, p1, p2); $ manage heap length from dynamic array
      63
      64
      65$ 'fc' is a function code with the following interpretation:
      66
      67$ fc=1:    set 'p1' to the current heap length, and 'p2' to the
      68$          maximum permitted heap length.
      69
      70$ fc=2:    set heap length to 'p1', and return change in heap
      71$          length in 'p2'.
      72
      73
      74      size fc(ws), p1(ws),p2(ws);
      75      size init(ws); data init=0;
      76      size n(ws);
      77      size max_length(ws), cur_length(ws);
      78      data max_length=0;
      79      data cur_length=0;
      80      size envmhl_opt(ws);
      81
      82      call getipp(envmhl_opt,'mhltr=0/1');
      83      if envmhl_opt then
      84          put ,'envmhl entry' :fc:p1:p2,nil ,skip;
      85      end if;
      86
      87      go to l(fc) in 1 to 2;
      88/l(1)/ $ query case
      89      if init=0 then $ if heap not allocated
      90          p1 = 0;
      91 .+s32v.
      92          $ s32v needs special call to set vaslim
      93          $ since no direct way to know how much
      94          $ new dynamic storage can be requested.
      95          size vaslim(ws);
      96          call getipp(vaslim,'vaslim=4193404/');  $ 4 megabyte default
      97          call envdsv(vaslim);
      98 ..s32v
      99          call envdsl(max_length); $ find maximum dynamic length.
     100          max_length = max_length -1; $ account for (heap_addr)
     101          p2 = max_length;
     102      else  $ if heap allocated
     103          p1 = cur_length;
     104          p2 = max_length;
     105      end if;
     106      go to exit;
     107
     108 /l(2)/ $ set case
     109      if init=0 then $ if initial allocation
     110          n = p1;
     111          if (n=0) n = p2;
     112          if (n=0) n = max_length;
     113          if (n>max_length) n = max_length;
     114          $ allocate heap, set starting address.
     115          call envdsa(heap_addr, n+1); $ try to allocate;
     116          if heap_addr<=0 then $ if could not allocate
     117              call err_fatal(41); $ report insufficient storage.
     118          end if;
     119          init = 1; $ indicate allocated
     120          max_length = n;
     121          if p1=0 then $ if initial 'null' heap.
     122              p2 = 0;
     123              return;
     124          end if;
     125          p1 = max_length;  $ set current length.
     126          p2 = p1-cur_length;
     127          cur_length = p1;
     128     else $ if allocated, try to increase
     129         if (p1>max_length) p1 = max_length;
     130         p2 = p1 - cur_length;
     131         cur_length = p1;
     132      end if;
     133 /exit/
     134      if envmhl_opt then
     135          put ,'envmhl exit' :fc:p1:p2,nil ,skip;
     136      end if;
     137      return;
     138      end subr;
     139 ..mhl_dynamic
     140
     141
     142 .+mhl_s66.
     143
     144      subr envmhl(fc, p1, p2); $ manage heap length for s66
     145
     146$ the s66 version of 'envmhl' uses blank common memory-management
     147$ routines provided by the little system.
     148
     149$ 'fc' is a function code with the following interpretation:
     150
     151$ fc=1:    set 'p1' to the current heap length, and 'p2' to the
     152$          maximum permitted heap length.
     153
     154$ fc=2:    set heap length to 'p1', and return change in heap
     155$          length in 'p2'.
     156
     157$ the following nameset is used to communicate with little's
     158$ memory management routines:
     159
     160      nameset 7nmbc6$ns;
     161          size bfc(ws),       $ function code
     162               bfr(ws);       $ return code
     163
     164          size bp1(ws),       $ parameters to memory request
     165               bp2(ws);
     166      end nameset 7nmbc6$ns;
     167
     168      size  fc(ps),           $ function code
     169            p1(ws),           $ first parameter
     170            p2(ws);           $ second parameter
     171
     172
     173      if fc = 1 then          $ return current and maximum lengths
     174          bfc = 1;            $ set function code
     175
     176          call 7nmbc6$li;
     177
     178          p1 = bp1;
     179          p2 = bp2;
     180
     181      elseif fc = 2 then      $ set length
     182          bp1 = p1;           $ enter desired length
     183          bfc = 2;            $ set function code
     184
     185          call 7nmbc6$li;
     186
     187          p1 = bp1;
     188          p2 = bp2;
     189      end if;
     190
     191
     192      end subr envmhl;
     193
     194 ..mhl_s66
     195
       1 .=member blksz
       2
       3 .+tr notrace entry;  $ turn off entry trace since this routine is
       4                      $ called from the dump routines.
       5
       6      fnct blksz(block);
       7
       8$ this routine determines the size of a heap block given a pointer
       9$ to it.
      10
      11$ if the block has an invalid htype we assume that it extends to the
      12$ next word with a valid htype.
      13
      14
      15      size block(ps);         $ pointer to block
      16
      17      size blksz(ps);         $ value returned
      18
      19      size ht(ps);            $ htype of block
      20
      21
      22      ht = htype(block);
      23
      24      if ht < h_min ! ht > h_max then  $ illegal type
      25          if ( ^ (gtrace & gdump)) call err_fatal(51);
      26          do blksz = 1 to h_lim;
      27              ht = htype(block + blksz);
      28              if (ht >= h_min & ht <= h_max) return;
      29          end do;
      30      end if;
      31
      32      go to case(ht) in h_min to h_max;
      33
      34
      35/case(h_latom)/               $ long atom
      36
      37      blksz = la_nwords(block);
      38      return;
      39
      40
      41/case(h_real)/                $ real
      42
      43      blksz = real_nw;
      44      return;
      45
      46
      47/case(h_lint)/                $ long integer
      48
      49      blksz = li_nwords(block);
      50      return;
      51
      52
      53/case(h_lstring)/             $ long character string
      54
      55      blksz = lc_nwords(block);
      56      return;
      57
      58
      59/case(h_tuple)/               $ tuple(general)
      60
      61/case(h_ituple)/              $ tuple(untyped integer)
      62
      63/case(h_rtuple)/              $ tuple(untyped real)
      64
      65      blksz = tuplen(block);
      66      return;
      67
      68
      69/case(h_ptuple)/              $ packed tuple
      70
      71      blksz = ptuplen(block);
      72      return;
      73
      74
      75/case(h_uset)/                $ unbased set
      76
      77      blksz = hl_uset;
      78      return;
      79
      80
      81/case(h_umap)/                $ unbased map
      82
      83      blksz = hl_umap;
      84      return;
      85
      86
      87/case(h_rset)/                $ remote set
      88
      89      blksz = hl_rset + rswords(block);
      90      return;
      91
      92
      93/case(h_rmap)/                $ remote map
      94
      95/case(h_rimap)/               $ remote integer map
      96
      97/case(h_rrmap)/               $ remote real map
      98
      99      blksz = hl_rmap + tuplen(block + hl_rmap);
     100      return;
     101
     102
     103/case(h_rpmap)/               $ remote packed map
     104
     105      blksz = hl_rpmap + ptuplen(block + hl_rpmap);
     106      return;
     107
     108
     109/case(h_lset)/                $ local set
     110
     111      blksz = hl_lset;
     112      return;
     113
     114
     115/case(h_lmap)/                $ local map
     116
     117/case(h_limap)/               $ local integer map
     118
     119/case(h_lrmap)/               $ local real map
     120
     121      blksz = hl_lmap;
     122      return;
     123
     124
     125/case(h_lpmap)/               $ local packed map
     126
     127      blksz = hl_lpmap;
     128      return;
     129
     130
     131/case(h_base)/                $ base
     132
     133      blksz = hl_base;
     134      return;
     135
     136
     137/case(h_ebb)/                 $ base element block
     138
     139$ the size of an element block is given by its 'ebsize' field.
     140$ this field is redundant for set and map eb-s since their size
     141$ is a system constant.  however for base elements, it is the
     142$ only way of telling the size of the block.
     143
     144$ since the value of ebsize is always quite small, it can never
     145$ be mistaken for a pointer into the garbage collectable
     146$ part of the heap.  we take advantage of this by allowing
     147$ 'ebsize' and 'hlink' to share the same field.
     148
     149$ during certain phases of the garbage collector, the ebsize field
     150$ will not contain the size of the element block, but rather will
     151$ contain the head of a list of pointers.  the null value which
     152$ terminates this list will be the size of the block.
     153
     154$ when the garbage collector is operating normally, we will
     155$ never ask for the size of an eb while its ebsize field
     156$ contains a pointer.  however we may do so in the garbage
     157$ collector trace mode.  in this case we must be prepared
     158$ to dereference the value in ebsize until we reach the
     159$ end of the list.
     160
     161      blksz = ebsize(block);
     162
     163 .+gt.
     164      while ^ isnull(blksz);
     165          blksz = stdptr(blksz);
     166      end while;
     167 ..gt
     168
     169      return;
     170
     171
     172/case(h_ebs)/                 $ set element block
     173
     174$ for set and map eb-s, we merely return the appropriate constant.
     175
     176      blksz = ebs_nw;
     177      return;
     178
     179
     180/case(h_ebm)/                 $ map element block
     181
     182      blksz = ebm_nw;
     183      return;
     184
     185
     186/case(h_ht)/                  $ hash table header
     187
     188      blksz = hl_ht;
     189      return;
     190
     191
     192/case(h_htb)/                 $ hash table block
     193
     194      blksz = hl_htb;
     195      return;
     196
     197
     198/case(h_code)/                $ code
     199
     200      blksz = codenw(block);
     201      return;
     202
     203
     204/case(h_istring)/             $ indirect string specifier block
     205
     206$ we should only reach here if string specifiers are stored indirectly
     207
     208 .+ssi.
     209      blksz = hl_ic;
     210      return;
     211 ..ssi
     212
     213 .-ssi.
     214      call err_fatal(42);
     215 ..ssi
     216
     217
     218      end fnct blksz;
     219
     220 .+tr trace entry;           $ restore entry trace
     221
     222
     223
     224
       1 .=member convert
       2      fnct convert(input, form);
       3
       4$ this is the main conversion routine. it converts any setl value
       5$ from one representation to another.
       6
       7$ 'convert' is recursive to handle nested types. however many of the
       8$ cases which do not require conversion are handled off line.
       9
      10$ the recursive part of the routine has two sections. the first
      11$ section seperates various gross cases such as primitive conversions,
      12$ locates, etc. the second section handles conversions for sets
      13$ and tuples. it is driven by the types of the input and output.
      14
      15$ we make two assumptions about the top level input:
      16
      17$ 1. it is not an untyped integer or real.
smfb 166$ 2. it does not have the desired type already.
      19
      20$ (2) means that a conversion will always be performed and we will
      21$ never set the share bit of the top level input.
      22
      23$ when we call 'convert' recursively, we assume (1) but not (2). this
      24$ means that we may have to set share bits of nested objects.
      25
      26$ on return from a recursive call we must check the share bit of
      27$ 'convert' and set the share bit of the input accordingly.
      28
      29
      30      size convert(hs);     $ specifier returned
      31
      32      size input(hs),    $ specifier for input
      33           form(ps);  $ desired output form
      34
      35$ arguments to recursive part of routine
      36      size in(hs),      $ specifier for input
      37           fm(ps);  $ form for output
      38
      39      size tstart(ps);   $ pointer to recursion stack at start of routi
      40
      41      size hd(hs),   $ specifier for head of pair
      42           tl(hs),    $ specifier for tail of pair
      43           el(hs),  $ specifier for set element
      44           im(hs),  $ map image
      45           bform(ps),  $ form of base
      46           ityp(ps),  $ input type
      47           otyp(ps),  $ output type
      48           n(ps),  $ nelt of set or tuple
      49           p(ps),  $ misc. pointer
      50           p1(ps),            $ misc. pointer
      51           j(ps);  $ do loop index
      52
      53      size copy1(hs),   $ functions called
      54           more_gen(ps),
      55           convut(hs),
      56           convss(hs),
      57           convmm(hs),
      58           convsm(hs),
      59           inext(hs),
      60           next(hs),
      61           rset1(hs),
      62           arb1(hs),
      63           nulltup(hs),
      64           nullset(hs),
      65           fval(hs),
      66           nullp(1);
      67
      68
      69$ stacked variables
      70
      71 .=zzyorg b $ reset counters for stack offsets
      72
      73      local(retpt);  $ return pointer
      74
      75      local(inp);    $ pointer to input set or tuple
      76      local(iform);   $ form of input
      77
      78      local(out);  $ specifier for output
      79      local(outp);    $ pointer to output set or tuple
      80      local(oform)  $ form of output
      81
      82      local(base);   $ pointer to base set
      83      local(pos);    $ pointer returned by locate
      84      local(mixed);  $ flags mixed tuple
      85
      86
      87      local(indx);   $ index for loop over tuples
      88      local(lim);     $ limit for loops over tuples
      89
      90      local(e);      $ pointer to current eb.
      91      local(im1);   $ map image
      92
      93      local(samed);  $ indicates two maps have same domain type
      94      local(samei);  $ indicates teo maps have same image type.
      95      local(multi)  $ flags multi valued image
      96
      97      deflab(case, t_tuple, t_map)  $ define case labels
      98
      99
     100$ begin execution
     101
     102 .+st init_time(st_conv);
     103      tstart = t;
     104
     105 .=zzyorg a    $ reset counter for return labels
     106
     107
     108
     109      in = input;
     110      fm = form;
     111
     112
     113
     114
     115
     116/entry/                      $ recursive entry point
     117
     118      r_entry;   $ save return pointer, etc.
     119
     120/switch/   $ select proper conversion
     121
     122$ if 'fm' is type general, recompute it as a function of the input type.
     123
     124      if fm = f_gen then
     125          if type_ in = t_map then
     126              fm = f_umap;
     127
     128          elseif type_ in = t_set then
     129              fm = f_uset;
     130
     131          elseif type_ in = t_tuple ! type_ in = t_stuple then
     132              fm = f_tuple;
     133
     134          else   $ no conversion needed
     135              convert = in;
     136              is_shared_ convert = yes;
     137              go to exit;
     138          end if;
     139      end if;
     140
     141      oform = fm;   $ save in stacked variable
     142
     143$ handle conversions to untyped integer and untyped real
     144
     145      if oform = f_uint then
     146          get_intval(convert, in);
     147          go to exit;
     148
     149      elseif oform = f_ureal then
     150          get_realval(convert, in);
     151          go to exit;
     152      end if;
     153
     154$ get the types of the input and output and select one of the
     155$ following cases:
     156
     157$ 1. input is omega. return omega of proper type.
     158
     159$ 2. output is type element. try to locate 'in' in the base. if
     160$    its not there, convert 'in' to the proper type then add it.
     161
     162$ 3. 'in' is type element. dereference it one level and try again.
     163
     164$ 4. input is primitive. make sure that it is the desired type
     165$    and do any necessary range check.
     166
     167$ 5. the result is primitive. return failure
     168
     169$ 6. 'in' is a set or tuple.
     170
     171$    a. oform = iform. return 'input' with its share bit set.
     172
     173$    b. oform is more general than iform. copy 'in' and reset
     174$       its form.
     175
     176$    c. perform a full conversion.
     177
     178
     179      ityp = type_ in;
     180      otyp = type(ft_samp(oform));
     181
     182      if is_om_ in then $ 1. input is omega
     183          if is_floc(oform) then
     184              if (is_fplex(oform)) go to exit1;
     185              convert = nullset(oform, 0);  $ null out base fields
     186              is_om_ convert = yes;
     187          else
     188              convert = heap(ft_samp(oform));
     189          end if;
     190          go to exit;
     191
     192      elseif otyp = t_elmt then  $ 2. output is type element
     193          bform = ft_base(oform);
     194          base = value(ft_samp(bform));
     195
     196          call locate(p, in, base, no);
     197
     198          if ^ loc_found then
     199              pos = p;        $ save pointer in stacked variables
     200
     201              fm = ft_elmt(bform);
     202              r_call;
     203
     204              p = pos;        $ restore pointer
     205              call insert(p, convert, base);
     206          end if;
     207
     208          build_spec(convert, t_elmt, p);
     209
     210          go to exit;
     211
     212      elseif ityp = t_elmt then  $ 3. input is type element
     213          deref(in);
     214
     215          r_call;
     217
     218          go to exit;
     219
     220      elseif isprim(ityp) then  $ 4. input is primitive
     221          if otyp = t_lint then    $ expect long or short int
     222              if (ityp ^= t_int & ityp ^= t_lint) go to exit1;
     223
     224          elseif otyp = t_int then  $ do range check
     225              if (ityp ^= t_int)           go to exit1;
     226              if (ivalue_ in < ft_low(fm)) go to exit1;
     227              if (ivalue_ in > ft_lim(fm) & ft_lim(fm) > 0) go to exit1;
stra 991
stra 992          elseif otyp = t_string ! otyp = t_istring then
stra 993              if (ityp ^= t_string & ityp ^= t_istring) go to exit1;
     228
     229          elseif otyp = t_atom then
     230              if (ityp ^= t_latom & ityp ^= t_atom) go to exit1;
     231
     232          elseif otyp = t_latom & ityp = t_latom then
     233              if (la_form(value_ in) ^= ft_base(oform)) go to exit1;
     234
     235          elseif ityp ^= otyp then  $ types must match
     236              go to exit1;
     237          end if;
     238
     239          convert = in;
     240          go to exit;
     241
     242      elseif isprim(otyp) then  $ 5. error
     243          go to exit1;
     244
     245      else    $ 6. sets and tuples
     246          inp = value_ in;
     247          iform = hform(inp);
     248
     249          if oform = iform then  $ 6a. types match
     250              convert = in;
     251              is_shared_ convert = yes;
     252              go to exit;
     253
     254          elseif more_gen(oform, iform) then  $ 6b. oform more general
     255              convert = copy1(in);
     256              p = value_ convert;
     257              hform(p) = oform;
     258              if ( ^ ft_hashok(oform)) is_hashok(p) = no;
     259              if ( ^ ft_neltok(oform)) is_neltok(p) = no;
     260              go to exit;
     261
     262          else   $ 6c. full conversion
     263              go to case(ityp, otyp) in minlab to maxlab;
     264          end if;
     265      end if;
     266
     267
     268/case(t_tuple, t_stuple)/   $ tuples
     269
     270/case(t_stuple, t_stuple)/
     271
     272/case(t_stuple, t_tuple)/
     273
smfb 167      convert = convut(in, oform);
     275      go to exit;
     276
     277
     278
     279/case(t_tuple, t_tuple)/
     280
     281$ this handles conversions from tuple(m1) to tuple(m2).
     282$ we begin by allocating a proper null tuple and setting its nelt, etc.
     283      n = nelt(inp);
     284
     285$ allocate and initialize null tuple
     286      out  = nulltup(fm, n);
     287      outp = value_ out;
     288
     289      set_nelt(outp, n);
     290
     291      if is_hashok(inp) then
     292          set_hash(outp, hash(inp));
     293      else
     294          is_hashok(outp) = no;
     295      end if;
     296
     297      $ initialize loop over elements
     298      indx = 1;   lim = n;
     299
     300      while indx <= lim;  $ loop over components
     301          in = tcomp(inp, indx);
     302
     303          if ft_type(oform) = f_mtuple then
smfd  53              if indx > ft_lim(oform) then
smfd  54                  call err_misc(56);
smfd  55                  convert = err_val(oform);
smfd  56                  t = tstart;
smfd  57                  return;
smfd  58              end if;
     304              fm = mttab(ft_elmt(oform) + indx);
     305          else
     306              fm = ft_elmt(oform);
     307          end if;
     308
     309          r_call;
     310
     311          tcomp(outp, indx) = convert;
     312          if (is_shared_ convert) is_shared_ tcomp(inp, indx) = yes;
     313
     314          indx = indx+1;
     315      end while;
     316
     317      convert = out;
     318      go to exit;
     319
     320
     321
     322
     323/case(t_set, t_set)/     $ sets
     324
     325$ see if both sets have the same element type. if so then we must
     326$ be converting from one representation of set(_ b) to another. these
     327$ conversions are handled off line.
     328
     329      if ft_elmt(iform) = ft_elmt(oform) then
     330          convert = convss(in, oform);
     331          go to exit;
     332      end if;
     333
     334
     335$ build null set for result, then set hash and nelt.
     336      ok_nelt(in);
     337      n = nelt(inp);
     338
     339      out  = nullset(fm, n);
     340      outp = value_ out;
     341
     342      set_nelt(outp, n);
     343
     344      if is_hashok(inp) then
     345          set_hash(outp, hash(inp));
     346      else
     347          is_hashok(outp) = no;
     348      end if;
     349
     350
     351$ iterate over 'in', inserting elements in 'out'.
     352      next_loop(e, inp);
     353
     354          if is_based(inp) then
     355              if (fval(inp, e, no) = no) cont;  $ not in set
     356              build_spec(in, t_elmt, e);
     357          else
     358              in = ebspec(e);
     359          end if;
     360
     361          fm = ft_elmt(oform);
     362
     363          r_call;
     364
     365$ if the result is 'local set(_ b)' or 'remote set(_ b)' then
     366$ 'convert' is now type '_ b', and we must merely set the
     367$ appropriate bit. otherwise we must insert 'convert' in the
     368$ result.
     369
     370          p1 = outp;          $ may be reset by sfval or insert
     371
     372          if is_based(outp) then
     373              call sfval(p1, value_ convert, yes);
     374
     375          else   $ store in result
     376              call insert(p, convert, p1);
     377              if (is_shared_ convert) is_shared_ ebspec(e) = yes;
     378          end if;
     379
     380          outp = p1;
     381
     382      end_next;
     383
     384      build_spec(convert, t_set, outp);
     385
     386      go to exit;
     387
     388
     389/case(t_map, t_map)/   $ maps
     390
     391$ we begin by setting two flags to indicate whether the domain and
     392$ image types match, then iterate over the input map.
     393
     394      samed = (ft_dom(iform) = ft_dom(oform));
     395
     396      samei = (ft_im(iform)  = ft_im(oform) &
     397              ft_mapc(iform) = ft_mapc(oform));
     398
     399      if samed & samei then $ convert local to remote, etc.
     400          convert = convmm(in, oform);
     401          go to exit;
     402      end if;
     403
     404$ allocate a null set,and set its nelt and hash
     405      ok_nelt(in);
     406      n = nelt(inp);
     407
     408      out  = nullset(fm, n);
     409      outp = value_ out;
     410
     411      set_nelt(outp, n);
     412
     413      if is_hashok(inp) then
     414          set_hash(outp, hash(inp));
     415      else
     416          is_hashok(outp) = no;
     417      end if;
     418
     419$ convert elements
     420
     421      next_loop(e, inp);
     422
     423$ if the input is based we must check whether 'e' is realy in the
     424$ domain. we do this by getting its image and ckecking that it is
     425$ defined.
     426
     427          im1 = fval(inp, e, yes);
     428
     429          if is_mmap(inp) then
     430              p = value_ im1;
     431
     432              if is_neltok(p) then
     433                  if (nelt(p) = 0) cont;
     434              else
     435                  if (nullp(p)) cont;
     436              end if;
     437
     438          else
     439              if (is_om_ im1) cont;
     440          end if;
     441
     442$ convert domain element
     443
     444          if samed then  $ domain types match
     445              convert = ebspec(e);
     446
     447          else
     448              if is_based(inp) then
     449                  build_spec(in, t_elmt, e);
     450              else
     451                  in = ebspec(e);
     452              end if;
     453
     454              fm = ft_dom(oform);
     455
     456              r_call;
     457
     458              if (is_shared_ convert) is_shared_ ebspec(e) = yes;
     459          end if;
     460
     461          call locate(p, convert, outp, yes);
     462          pos = p;
     463$
     464$ convert image
     465$
     466          if samei then       $ no conversion needed
     467              convert = im1;
     468
     469          else  $ set up for image conversion
     470              in = im1;
     471              fm = ft_im(oform);
     472
     473              multi = is_multi_ in;
     474
     475              if ^ is_mmap(outp) & multi = yes then
     476                  in = arb1(in);   $ actually multi-valued ?
     477
     478                  if is_multi_ in then
     479                      if (is_smap(outp)) go to error;
smfa  58                      fm = ft_imset(oform); multi = yes;
     480                      assert fm = f_gen ! is_fset(fm);
     481                  else
     482                      multi = no;
     483                  end if;
     484
     485              elseif is_mmap(outp) & multi = no then
     486                  in = rset1(in);
     487                  multi = yes;
     488              end if;
     489
     490              r_call;
     491
     492              is_multi_ convert = multi;
     493          end if;
     494
     495          p1 = outp;          $ may be changed by 'sfval'
     496          call sfval(p1, pos, convert);
     497          outp = p1;
     498
     499      end_next;
     500
     501      build_spec(convert, t_map, outp);
     502
     503      go to exit;
     504
     505
     506
     507
     508/case(t_set, t_map)/
     509
     510      if is_ftup(ft_elmt(iform)) &
     511              ft_elmt(iform) = ft_elmt(oform) then
     512          convert = convsm(in, oform);
     513          go to exit;
     514
     515      else  $ convert to map(*)* then to proper map
     516          in = convsm(in, f_umap);
     517          go to switch;
     518      end if;
     519
     520
     521
     522
     523/case(t_map, t_set)/
     524
     525$ convert to set(*) then to proper set type
     526      call convset(in);
     527      go to switch;
     528
     529
     530
     531
     532
     533
     534
     535
     536
     537
     538
     539/case(t_tuple, t_set)/    $ error cases
     540
     541/case(t_tuple, t_map)/
     542
     543/case(t_stuple, t_set)/
     544
     545/case(t_stuple, t_map)/
     546
     547/case(t_set, t_tuple)/
     548
     549/case(t_set, t_stuple)/
     550
     551/case(t_map, t_tuple)/
     552
     553/case(t_map, t_stuple)/
     554
     555      go to exit1;
     556
     557
     558
     559
     560/exit/    $ normal exit
     561
     562
     563
     564      r_exit;    $ pop stack
     565
     566      if t ^= tstart then    $ recursive return
     567          go to rlab(retpt) in 1 to zzya;
     568      else
smfb 168          $ the top-level value is unshared if it is not a sample value.
smfb 169          if is_om_ convert = no then maycopy(convert); end if;
     569 .+st     save_time(st_conv);
     570          return;
     571      end if;
     572
     573
     574
     575/exit1/  $ return proper omega
     576
     577/error/
     578
     579      call err_misc(43);
     580      convert = err_val(f_gen);
     581      t = tstart;
     582
     583      return;
     584
     585
     586
     587$ drop local variables
     588
     589      macdrop8(retpt, inp, iform, out, outp, oform, base, pos);
     590      macdrop4(mixed, indx, lim, e)
     591      macdrop2(samed, samei)
     592      macdrop2(multi, im1)
     593
     594      macdrop(case)  $ drop case labels
     595
     596      end fnct convert;
       1 .=member convss
       2      fnct convss(in, form);
       3
       4$ conv-ert s-et to s-et
       5
       6$ this routine converts 'set(_b)' from local to remote, etc.
       7$ 'in' is the input set, and 'form' is the output type.
       8
       9
      10      size convss(hs);    $ specifier returned
      11
      12      size in(hs),    $ specifier for input
      13           form(ps);  $ form for result
      14
      15      size inp(ps),   $ pointer to input
      16           outp(ps);  $ pointer to output
      17
      18      size n(ps),   $ nelt of input
      19           e(ps),   $ pointer to eb
      20           p(ps),   $ pointer to range set
      21           spec(hs),  $ specifier for base element
      22           pos(ps);   $ pointer returned by -insert-
      23
      24      size fval(hs),  $ functions called
      25           nullset(hs),
      26           copy1(hs);
      27
      28
      29 .+st init_time(st_cset);
      30
      31$ allocate a null set. at the moment we make the null set the same
      32$ size as the input. a better scheme, which we might use later, is
      33$ to allocate a set whose size is the minimum of the maximum index in
      34$ the base and the amount of free heap space.
      35
smfb 170      ok_nelt(in);            $ update nelt of input
      37
      38      inp = value_ in;
      39      n = nelt(inp);
      40
      41      convss = nullset(form, n);     $ get null set
      42      outp = value_ convss;
      43
      44      set_nelt(outp, n);
      45
      46      if is_hashok(inp) then
      47          set_hash(outp, hash(inp));
      48      else
      49          is_hashok(outp) = no;
      50      end if;
      51
      52$ jump on htypes of input and output
      53
      54      deflab(case, h_uset, h_rset);   $ define case labels
      55
      56      go to case(htype(outp), htype(inp)) in minlab to maxlab;
      57
      58
      59
      60
      61/case(h_lset, h_rset)/      $ based = based
      62
      63/case(h_rset, h_lset)/
      64
      65/case(h_lset, h_lset)/
      66
      67/case(h_rset, h_rset)/
      68
      69$ iterate over base, applyinf fval to input and sfval to output
      70      next_loop(e, inp);
      71
      72          if (fval(inp, e, no) = no) cont;  $ not in input
      73
      74          call sfval(outp, e, yes);   $ add to output
      75      end_next;
      76
      77      go to done;
      78
      79
      80/case(h_lset, h_uset)/            $ based = unbased
      81
      82/case(h_rset, h_uset)/
      83
      84$ iterate over unbased set, getting pointers into base and
      85$ setting membership bits.
      86
      87      next_loop(e, inp);
      88          p = value_ ebspec(e);
      89          call sfval(outp, p, yes);    $ add to output
      90      end_next;
      91
      92      go to done;
      93
      94
      95/case(h_uset, h_lset)/          $ unbased = based
      96
      97/case(h_uset, h_rset)/
      98
      99$ iterate over based set, building specifiers of type _b, then
     100$ add them to output.
     101
     102      next_loop(e, inp);
     103
     104          if (fval(inp, e, no) = no) cont;
     105
     106          build_spec(spec, t_elmt, e);
     107          call insert(pos, spec, outp);
     108      end_next;
     109
     110      go to done;
     111
     112
     113/case(h_uset, h_uset)/      $ unbased = unbased
     114
     115      convss = copy1(in);
     116      return;
     117
     118
     119/done/   $ set nelt and hash then return
     120
     121      value_ convss = outp;
     122
     123 .+st save_time(st_cset);     $ save statistics
     124
     125      return;
     126
     127      macdrop(case)   $ drop case label
     128
     129      end fnct convss;
       1 .=member convmm
       2      fnct convmm(in, form);
       3
       4$ conv-ert m-ap to m-ap
       5
       6$ this routine converts 'map(_b)m' from local to remote, etc.
       7$ 'in' is the input map, and 'form' is the output type.
       8
       9
      10      size convmm(hs);    $ specifier returned
      11
      12      size in(hs),    $ specifier for input
      13           form(ps);  $ form of result
      14
      15      size inp(ps),   $ pointer to input
      16           outp(ps);  $ pointer to output
      17
      18      size n(ps),   $ nelt of input
      19           ht1(ps),  $ htypes
      20           ht2(ps),
      21           e(ps),   $ pointer to eb
      22           p(ps),   $ pointer to range set
      23           dom(hs),  $ specifier for domain
      24           im(hs),  $ image specifier
      25           pos(ps);   $ pointer returned by -insert-
      26
      27      size fval(hs),  $ functions called
      28           nullset(hs),
      29           copy1(hs);
      30
      31
      32 .+st init_time(st_cset);
      33
      34$ allocate a null set. at the moment we make the null set the same
      35$ size as the input. a better scheme, which we might use later, is
      36$ to allocate a set whose size is the minimum of the maximum index in
      37$ the base and the amount of free heap space.
      38
      39      ok_nelt(in);        $ uodate nelt of input
      40
      41      inp = value_ in;
      42      n = nelt(inp);
      43
      44      convmm = nullset(form, n);     $ get null set
      45      outp = value_ convmm;
      46
      47      set_nelt(outp, n);
      48
      49      if is_hashok(inp) then
      50          set_hash(outp, hash(inp));
      51      else
      52          is_hashok(outp) = no;
      53      end if;
      54
      55$ jump on the 'maptypes' of the input and output. this lumps all
      56$ remote maps together, etc.
      57      deflab(case, m_min, m_max)
      58
      59      ht1 = htype(inp);
      60      ht2 = htype(outp);
      61
      62      go to case(maptype(ht2), maptype(ht1)) in minlab to maxlab;
      63
      64
      65/case(m_lmap, m_rmap)/      $ based = based
      66
      67/case(m_rmap, m_lmap)/
      68
      69/case(m_lmap, m_lmap)/
      70
      71/case(m_rmap, m_rmap)/
      72
      73$ iterate over base, applyinf fval to input and sfval to output
      74      next_loop(e, inp);
      75
      76          im = fval(inp, e, yes);
      77          call sfval(outp, e, im);
      78      end_next;
      79
      80      go to done;
      81
      82
      83/case(m_lmap, m_umap)/            $ based = unbased
      84
      85/case(m_rmap, m_umap)/
      86$ iterate over unbased set, getting pointers into base and
      87$ setting images.
      88
      89      next_loop(e, inp);
      90          dom = value_ ebspec(e);
      91
      92          is_shared_ ebimag(e) = yes;
      93          im = ebimag(e);
      94
      95          call sfval(outp, dom, im);
      96      end_next;
      97
      98      go to done;
      99
     100
     101/case(m_umap, m_lmap)/          $ unbased = based
     102
     103/case(m_umap, m_rmap)/
     104
     105$ iterate over based set, building specifiers of type element and
     106$ inserting pairs in the unbased map.
     107
     108      next_loop(e, inp);
     109
     110          build_spec(dom, t_elmt, e);
     111          im = fval(inp, e, yes);
     112
     113          call insert(pos, dom, outp);
     114          call sfval(outp, pos, im);
     115      end_next;
     116
     117      go to done;
     118
     119
     120/case(m_umap, m_umap)/      $ unbased = unbased
     121
     122      convmm = copy1(in);
     123
     124      return;
     125
     126
     127/done/   $ set nelt and hash then return
     128
     129      value_ convmm = outp;
     130
     131 .+st save_time(st_cset);     $ save statistics
     132
     133      return;
     134
     135      macdrop(case)   $ drop case label
     136
     137      end fnct convmm;
       1 .=member convsm
       2      fnct convsm(in, form);
       3
       4$ conv-ert s-et to m-ap
       5
       6$ this routine converts 'set([m1, m2])' to 'map(m1)m2'.
       7
       8
       9
      10$ for lack of a better estimate we allocate a null set whose sizze
      11$ is the cardinality of -in-. we then iterate for all e _ in. if e
      12$ is a non pair we fail. otherwise we split it into its head and tail
      13$ and convert them. finally we locate the head of the pair in the
      14$ domain and add its tail to the image.
      15
      16
      17      size convsm(hs);   $ specifier returned
      18
      19      size in(hs),    $ specifier for input
      20           form(ps);  $ form of map
      21
      22      size inp(ps),  $ pointer to input
      23           outp(ps),
      24           e(ps),    $ pointer to current eb of set
      25           elmt(hs),  $ eb specifier
      26           n(ps),  $ nelt of input
      27           pos(ps),  $ ptr returned by insert.
      28           pair(ps);  $ pointer to pair
smfc 269      size ptr(ps);           $ junk pointer for insert
smfc 270      size s(ps);             $ pointer to image set
      29
      30      size hd(hs),     $ speifiers for components of pairs
      31           tl(hs),
      32           im(hs),      $ currenr image of hd.
      33           set(hs);  $ range set
      34
      35      size nullset(hs),   $ functions called
      36           fval(hs),
      37           withs(hs),
      38           rset2(hs);
      39
      40
      41 .+st init_time(st_cset);
      42
      43$ allocate a null set. at the moment we make the null set the same
      44$ size as the input. a better scheme, which we might use later, is
      45$ to allocate a set whose size is the minimum of the maximum index in
      46$ the base and the amount of free heap space.
      47
      48      inp = value_ in;
      49
      50      ok_nelt(in);
      51      n = nelt(inp);         $ get nelt of input
      52
      53      convsm = nullset(form, n);  $ get null set
      54      outp = value_ convsm;
      55
      56      set_nelt(outp, n);
      57
      58      if is_hashok(inp) then
      59          set_hash(outp, hash(inp));
      60      else
      61          is_hashok(outp) = no;
      62      end if;
      63
      64      $ set up variables for element conversion
      65      next_loop(e, inp);   $ iterate over old set
smfc 271          if is_based(inp) then
smfc 272              if (fval(inp, e, no) = no) cont;
smfc 273          end if;
      66
      67          elmt = ebspec(e);
      68          deref(elmt);
      69
      70          if (type_ elmt ^= t_tuple) go to fail;
      71
      72          pair = value_ elmt;
      73          if (nelt(pair) ^= 2) go to fail;
      74
      75          is_shared_ tcomp(pair, 1) = yes; $ set share bits in pair
      76          is_shared_ tcomp(pair, 2) = yes;
      77
      78          hd = tcomp(pair, 1); $ split into head and tail
      79          tl = tcomp(pair, 2);
      80
      81          $ if the hd is omega, this is an illegal conversion
      82          if (is_om_ hd) go to fail;
      83
      84          $ see if hd is already in the domain
      85          call locate(pos, hd, outp, yes);
      86
      87          $ merge tl with the old image
      88          im = fval(outp, pos, no);
      89
      90          if is_om_ im then
      91              im = tl;
      92
      93          elseif is_multi_ im then
      94              is_shared_ tl = yes;
      95              im = withs(im, tl, no);
      96              is_multi_ im = yes;
      97
      98          else
      99              if (is_smap(outp)) go to fail;  $ becoming multivalued.
smfc 274              set = nullset(ft_imset(form), 2); s = value_ set;
smfc 275              call insert(ptr, im, s); call insert(ptr, tl, s);
smfc 276              value_ set = s; is_multi_ set = yes; im = set;
     102
     103          end if;
     104
     105          call sfval(outp, pos, im);   $ store new image
     106
     107      end_next;
     108
     109      value_ convsm = outp;
     110
     111 .+st save_time(st_cset);     $ save statistics
     112
     113      return;
     114
     115
     116/fail/           $ return error value
     117
     118      call err_misc(44);
     119      convsm = err_val(form);
     120
     121      return;
     122
     123
     124      end fnct convsm;
       1 .=member convut
       2      fnct convut(in, form);
       3
       4$ this routine converts standard tuple to untyped tuples and visa
       5$ versa.
       6
       7
       8      size convut(hs);        $ specifier returned
       9
      10      size in(hs),            $ specifier for input tuple
      11           form(ps);          $ pointer to sample value
      12
      13      size j(ps),             $ loop index
      14           n(ps),             $ loop limit = nelt(input tuple)
      15           oldp(ps),          $ pointer to input tuple
      16           newp(ps),          $ pointer to output tuple
      17           oldc(hs),          $ specifier for input component
      18           temp(hs),          $ temporary specifier
      19           newc(hs);          $ specifier for output component
      20
      21      size nulltup(hs);       $ function called
      22
      23
      24      oldp = value_ in;       $ get pointer to input tuple
      25
      26$ allocate null tuple for output
      27
      28      ok_nelt(in);
      29      n = nelt(oldp);
      30
      31      convut = nulltup(form, n);
      32      newp = value_ convut;
      33
      34$ copy hash and nelt
      35
      36      set_nelt(newp, n);
      37
      38      if is_hashok(oldp) then
      39          set_hash(newp, hash(oldp));
      40      else
      41          is_hashok(newp) = no;
      42      end if;
      43
      44$ define case labels and jump on htypes of output and input
      45
      46      deflab(case, h_tuple, h_rtuple);
      47
      48      go to case(htype(newp), htype(oldp)) in minlab to maxlab;
      49
      50
      51/case(h_tuple, h_ptuple)/     $ standard tuple := packed tuple
      52
      53      do j = 1 to n;
      54          oldc = pcomp(oldp, j);
      55          unpack(ptkey(oldp), oldc, newc);
      56
      57          tcomp(newp, j) = newc;
      58      end do;
      59
      60      return;
      61
      62
      63/case(h_tuple, h_ituple)/     $ standard tuple := untyped integer tuple
      64
      65      do j = 1 to n;
      66          oldc = tcomp(oldp, j);
      67          put_intval(oldc, newc);
      68
      69          tcomp(newp, j) = newc;
      70      end do;
      71
      72      return;
      73
      74
      75/case(h_tuple, h_rtuple)/     $ standard tuple := untyped real tuple
      76
      77      do j = 1 to n;
      78          oldc = tcomp(oldp, j);
      79          put_realval(oldc, newc);
      80
      81          tcomp(newp, j) = newc;
      82      end do;
      83
      84      return;
      85
      86
      87/case(h_ptuple, h_tuple)/     $ packed tuple := standard tuple
      88
      89      do j = 1 to n;
      90          oldc = tcomp(oldp, j);
      91
      92          pack(ptkey(newp), newc, oldc);
      93          pcomp(newp, j) = newc;
      94      end do;
      95
      96      return;
      97
      98
      99/case(h_ptuple, h_ituple)/    $ packed tuple := untyped integer tuple
     100
     101      do j = 1 to n;
     102          oldc = tcomp(oldp, j);
     103          put_intval(oldc, temp);
     104
     105          pack(ptkey(newp), newc, temp);
     106          pcomp(newp, j) = newc;
     107      end do;
     108
     109      return;
     110
     111
     112/case(h_ptuple, h_rtuple)/    $ packed tuple := untyped real tuple
     113
     114      do j = 1 to n;
     115          oldc = tcomp(oldp, j);
     116          put_realval(oldc, temp);
     117
     118          pack(ptkey(newp), newc, temp);
     119          pcomp(newp, j) = newc;
     120      end do;
     121
     122      return;
     123
     124
     125/case(h_ituple, h_tuple)/     $ untyped integer tuple := standard tuple
     126
     127      do j = 1 to n;
     128          oldc = tcomp(oldp, j);
     129
     130          get_intval(newc, oldc);
     131          tcomp(newp, j) = newc;
     132      end do;
     133
     134      return;
     135
     136
     137/case(h_ituple, h_ptuple)/    $ untyped integer tuple := packed tuple
     138
     139      do j = 1 to n;
     140          oldc = pcomp(oldp, j);
     141          unpack(ptkey(oldp), oldc, temp);
     142
     143          get_intval(newc, temp);
     144          tcomp(newp, j) = newc;
     145      end do;
     146
     147      return;
     148
     149
     150/case(h_rtuple, h_tuple)/     $ untyped real tuple := standard tuple
     151
     152      do j = 1 to n;
     153          oldc = tcomp(oldp, j);
     154
     155          get_realval(newc, oldc);
     156          tcomp(newp, j) = newc;
     157      end do;
     158
     159      return;
     160
     161
     162/case(h_rtuple, h_ptuple)/    $ untyped real tuple := packed tuple
     163
     164      do j = 1 to n;
     165          oldc = pcomp(oldp, j);
     166          unpack(ptkey(oldp), oldc, temp);
     167
     168          get_realval(newc, temp);
     169          tcomp(newp, j) = newc;
     170      end do;
     171
     172      return;
     173
     174
     175/case(h_ituple, h_rtuple)/  $ illegal cases
     176
     177/case(h_rtuple, h_ituple)/
     178
     179/case(h_tuple, h_tuple)/
     180
     181/case(h_ptuple, h_ptuple)/
     182
     183/case(h_ituple, h_ituple)/
     184
     185/case(h_rtuple, h_rtuple)/
     186
     187      call err_fatal(43);
     188
     189
     190      macdrop(case)  $ drop case label
     191
     192      end fnct convut;
       1 .=member convset
       2      subr convset(arg);
       3
       4$ this routine converts any representation of a set or map into
       5$ an unbased set(*).
       6
       7$ variable declarations
       8
       9      size arg(hs);   $ specifier for input and output
      10
      11      size oldp(ps),  $ pointer to old set
      12           new(hs),   $ specifier for result
      13           newp(ps),  $ pointer to new set
      14           pos(ps),   $ pointer set by insert routine
      15           el(hs),    $ element extracted from old set
      16           iter(hs);  $ iterator used by next routine
      17
      18      size nullset(hs);  $ function called
      19
      20
      21/begin/     $ begin execution
      22
      23$ see if arg is already the desired type
      24      oldp = value_ arg;
      25      if (hform(oldp) = f_uset) return;
      26
      27$ allocate a null set with the same number of elements
      28      ok_nelt(arg);
      29
      30      new  = nullset(f_uset, nelt(oldp));
      31      newp = value_ new;
      32
      33$ iterate over old set, adding elements to new set
      34
      35      call inext(el, iter, arg);
      36
      37      while 1;
      38          call next(el, iter, arg);
      39          if (is_om_ el) quit;
      40
      41          call insert(pos, el, newp);
      42      end while;
      43
      44      set_nelt(newp, nelt(oldp));
      45      is_hashok(newp) = no;
      46
      47      arg = new;
      48
      49      return;
      50
      51      end subr convset;
       1 .=member moregen
       2      fnct more_gen(fm1, fm2);
       3
       4$ this routine determines if a form fm1 is more general than another
       5$ form fm2.
       6
       8
       9      size more_gen(1);       $ boolean value returned
      10
      11      size fm1(ps),  $ input forms
      12           fm2(ps);
      13
      14      size f1(ps),  $ copies of arguments
      15           f2(ps),
      16           t1(ps),  $ their types
      17           t2(ps);
      18
      19
      22      f1 = fm1;
      23      f2 = fm2;
      24
      25/test/
      26
      27      if (f1 = f2) go to pass;
      28
      29      t1 = ft_type(f1);
      30      t2 = ft_type(f2);
      31
      32      if (t1 = f_int & t2 = f_sint) go to pass;
      33
      34      if (t1 ^= t2) go to fail;
      35
      36      if t1 = f_sint then
      37          if (ft_lim(f1) >= ft_lim(f2) & ft_lim(f2) > 0) go to pass;
      38          go to fail;
      39
      40      elseif t1 = f_gen then
      41          go to pass;
      42
      43      elseif t1 = f_elmt then
      44          go to fail;
      45
      46      elseif is_fprim(f1) then
      47          go to pass;
      48
      49      elseif t1 = f_mtuple then  $ be pessimistic
      50          go to fail;
      51
      52      elseif is_floc(t1) ! is_floc(t2) then
      53          go to fail;
      54
      55      elseif is_ftup(f1) then
smfb 171          if (ft_lim(f1) > ft_lim(f2)) go to fail;
      56          f1 = ft_elmt(f1);
      57          f2 = ft_elmt(f2);
      58          go to test;
      59
      60      else  $ sets and tuples - compare elements
      61          $ this case must be handled recusively, checking both
      62          $ the domain and range forms.  the current form, namely
      63          $ to check the element form, does not check the range
      64          $ set types correctly.
      65          go to fail;
      66
      67          if (ft_mapc(f1) ^= ft_mapc(f2)) go to fail;
      68
      69          f1 = ft_elmt(f1);
      70          f2 = ft_elmt(f2);
      71          go to test;
      72
      73      end if;
      74
      75
      76/pass/
      77
      78      more_gen = yes;
      79      return;
      80
      81/fail/
      82
      83      more_gen = no;
      84      return;
      85
      86      end fnct more_gen;
       1 .=member errfatal
       2
       3$ disable trace for debugging and dump routines
       4
       5 .+tr notrace entry;
       6 .+tr notrace stores;
       7
       8$ the routines err_xxx process error conditions encountered
       9$ during exection.
      10
      11$ there are two different types of errors:
      12
      13$ 1. errors that always terminate, such as implementation
      14$    and most i/o errors.  these errors are handled by
      15$    -err_fatal-.
      16
      17$ 2. errors that propagate up to a predefined error limit.
      18$    these errors are handled by the routines -err_om-,
      19$    -err_type-, and -err_misc-.
      20
      21$ these routines call one common
      22$ error processing routine (-err_proc-), which prints
      23$ the error message, and either recovers or terminates
      24$ execution.
      25
      26
      27      subr err_fatal(i);
      28
      29$ this subroutine prints run-time diagnostic messages that
      30$ are implementation dependent.  -i- is the message number.
      31
      32
      33      size i(ps),             $ diagnostic message number
      34           msg(.sds. 80);     $ message text
      35
      36
      37      +*  err_max  =  62  **  $ number of error messages
      38
      39      if ( ^ (1 <= i & i <= err_max)) i = 0;
      40
      41      go to case(i) in 0 to err_max;
      42
      43      +*      et(n, string) =
      44              /case(n)/    msg = string; go to esac;
      45              **
      46
      47      et(00, 'invalid error text index --- err_fatal.')
      48      et(01, 'too many blank atoms.')
      49      et(02, 'invalid q2 address.')
      50      et(03, 'invalid q2 opcode.')
      51      et(04, 'attempt to execute a noop.')
      52      et(05, 'long integer too long for implementation.')
      53      et(06, '-i- too large for machine in -t(i) := y-.')
      54      et(07, 'calling fval on unbased set.')
      55      et(08, 'calling sfval on unbased set.')
      56      et(09, 'long integer too long for implementation.')
      57      et(10, 'long integer too long for implementation.')
      58      et(11, 'attempt to open string file.')
      59      et(12, 'attempt to print label or procedure.')
      60      et(13, '-err_count <= b <= maxsi- is violated in -setem(a, b)-.')
      61      et(14, 't ^= savet - read2.')
      62      et(15, 'end-of-file encountered while reading set or tuple.')
      63      et(16, 'attempt to read invalid setl object.')
      64      et(17, 'read routine encountered mismatched brackets.')
      65      et(18, 'attempt to read long integer.')
      66      et(19, 'string size exceeds line size in -put(s)-.')
      67      et(20, 'permanent i/o error in binary write (-put-).')
      68      et(21, 't ^= savet - getb1.')
      69      et(22, 'permanent i/o error in binary read (-get-).')
      70      et(23, 'illegal change of error mode.')
      71      et(24, 'keyed i/o not implemented.')
      72      et(25, 'permanent i/o error in foreign read (-getf-).')
      73      et(26, 'permanent i/o error in foreign write (-putf-).')
      74      et(27, 'keyed i/o not implemented.')
      75      et(28, 'illegal use of file.')
      76      et(29, 'too many files.')
      77      et(30, 'doing i/o on unopened file.')
      78      et(31, 'illegal file mode.')
      79      et(32, 'trying to copy local set.')
      80      et(33, 'trying to copy local map.')
      81      et(34, 'trying to copy local map.')
      82      et(35, 'ebindx too large.')
      83      et(36, 'insertion in constant base.')
      84      et(37, 'main storage pool exhausted during i/o operation.')
      85      et(38, 'insufficient work space for garbage collection (grbmrk)')
      86      et(39, 'found indirect string block in heap.')
      87      et(40, 'garbadj - len = 0.')
      88      et(41, 'main storage pool exhausted.')
      89      et(42, 'found indirect character block in heap.')
      90      et(43, 'reaching illegal case - convut.')
      91      et(44, 'nelt field overflow.')
      92      et(45, 'writing error value');
      93      et(46, 'garbcol found code block');
      94      et(47, 'executed -fail- in primal environment');
      95      et(48, 'executed -succeed- in primal environment');
      96      et(49, 'feature not implemented')
      97      et(50, 'insufficient work space for garbage collection (nullp)')
      98      et(51, 'system failure - illegal htype in -blksz-')
      99      et(52, 'no main program or directory/module incompatibility')
     100      et(53, 'attempt to open omega as file')
     101      et(54, 'error in experimental feature -- please report')
     102      et(55, 'not yet implemented')
     103      et(56, 'system failure - page overlap in hfcrst - please report')
     104      et(57, 'invalid communication area index in foreign interface')
     105      et(58, 'invalid communication area slice in foreign interface')
     106      et(59, 'invalid datum in foreign interface')
     107      et(60, 'missing vector with external procedure adresses')
     108      et(61, 'invalid external procedure index in foreign interface')
     109      et(62, 'illegal binary file format');
     110
     111
     112/esac/
     113      call err_proc(msg, yes); $ force abnormal termination
     114
     115      macdrop(err_max)
     116
     117      end subr err_fatal;
       1 .=member errq2
       2      subr err_q2(typ);
       3
       4      size typ(ps); $ error sub type
       5
       6      if typ = 0 then          $ empty q2 file
       7          call libterm(0);    $ just terminate normally
       8      end if;
       9
smfb 172      put, skip;
      11      call contlpr(27, yes);  $ start echo to terminal
      12 .+s10    put, '?';            $ dec-10 error flag character
      13
      14      go to case(typ) in 1 to 3;
      15
      16 /case(1)/                    $ bad check word
      17
smfb 173      put ,'setl error:  code file is not formatted correctly --- '
smfb 174          ,'bad initial check word.'
smfb 175          ,skip;
      20      go to esac;
      21
      22 /case(2)/
smfb 176      put ,'setl error:  empty code file follows check word.' ,skip;
      24      go to esac;
      25
      26 /case(3)/
smfb 177      put ,'setl error:  obsolete code file, please recompile.' ,skip;
smfb 178      $ go to esac;
smfb 179
      47 /esac/
      48          call contlpr(27, no);   $ stop echo to terminal
smfb 180          put, skip;
      50          call remarkl('  setl error - code file has bad format');
      51          call ltlfin(1, 0);    $ abnormally terminate execution
      52
      53      end subr;
       1 .=member errom
       2      subr err_om(i);
       3
       4$ this subroutine prints run-time diagnostic messages that
       5$ relate to unexpected omega values during execution.
       6$ -i- is the diagnostic message number.
       7
       8
       9      size i(ps),             $ diagnostic message number
      10           msg(.sds. 80);     $ message text
      11
      12
      13      +*  err_max  =  48  **  $ number of error messages
      14
      15      if ( ^ (1 <= i & i <= err_max)) i = 0;
      16
      17      go to case(i) in 0 to err_max;
      18
      19      et(00, 'invalid error text index --- err_om.')
      20      et(01, '-s- is omega in -s with x-.')
      21      et(02, '-x- is omega in -s with x-.')
      22      et(03, '-s- is omega in -x from s-.')
      23      et(04, '-s- is omega in -e in s-.')
      24      et(05, '');
      25      et(06, '-f- is omega in -f(x) := y-.')
      26      et(07, 'attempt to iterate over omega value.')
      27      et(08, 'attempt to iterate over omega value.')
      28      et(09, 'attempt to iterate over omega value.')
      29      et(10, 'attempt to iterate over omega value.')
      30      et(11, '-t- and/or -s- is omega in -spec(t,s)-.')
      31      et(12, '-x- is omega in -unspec(x)-.')
      32      et(13, 'illegal use of omega.')
      33      et(14, 'inserting omega in a set or map.')
      34      et(15, '-x- is omega in -# x-.')
      35      et(16, 'attempt to extract element from omega value.')
      36      et(17, '-s- is omega in -x := s(i:j)-.')
      37      et(18, '-y- is omega in -s(i:j) := y-.')
      38      et(19, 'operand is omega in -<- or ->-.')
      39      et(20, 'operand is omega in -<=- or ->=-.')
      40      et(21, '-x- is omega in -abs(x)-.')
      41      et(22, '-x- is omega in -x ** y-.')
      42      et(23, '-y- is omega in -x ** y-.')
      43      et(24, '-x- is omega in -ceil x-.')
      44      et(25, '-x- is omega in -floor x-.')
      45      et(26, '-x- is omega in -fix x-.')
      46      et(27, '-x- is omega in -float x-.')
      47      et(28, '-t- is omega in -x fromb t-.')
      48      et(29, '-t- is omega in -x frome t-.')
      49      et(30, '-f- is omega in -domain f-.')
      50      et(31, '-f- is omega in -range f-.')
      51      et(32, '-f- is omega in -y := f(x)-')
      52      et(33, '-f- is omega in -y := f<>-')
      53      et(34, '-f- is omega in -f<> := y-')
      54      et(35, '-i- is omega in -char i-.')
      55      et(36, '-x- is omega in -x atan2 y-.')
      56      et(37, '-y- is omega in -x atan2 y-.')
      57      et(38, '-x- is omega in -acos x-.')
      58      et(39, '-x- is omega in -asin x-.')
      59      et(40, '-x- is omega in -atan x-.')
      60      et(41, '-x- is omega in -cos x-.')
      61      et(42, '-x- is omega in -exp x-.')
      62      et(43, '-x- is omega in -log x-.')
      63      et(44, '-x- is omega in -sin x-.')
      64      et(45, '-x- is omega in -sqrt x-.')
      65      et(46, '-x- is omega in -tan x-.')
      66      et(47, '-x- is omega in -tanh x-.')
      67      et(48, '-x- is omega in -random x-.')
      68
      69/esac/
      70
      71      macdrop(err_max)
      72      call err_proc(msg, no);
      73
      74      end subr err_om;
       1 .=member errtype
       2      subr err_type(i);
       3
       4$ this subroutine prints run-time diagnostic messages that
       5$ refer to type errors.  -i- is the message number.
       6
       7
       8      size i(ps),             $ diagnostic message number
       9           msg(.sds. 80);     $ message text
      10
      11
      12      +*  err_max  =  81  **  $ number of error messages
      13
      14      if ( ^ (1 <= i & i <= err_max)) i = 0;
      15
      16      go to case(i) in 0 to err_max;
      17
      18      et(00, 'invalid error text index --- err_type.')
      19      et(01, 'attempt to extract integer value from non-integer.')
      20      et(02, 'illegal type for -a- in -a + b-.')
      21      et(03, 'incompatible types for -a- and -b- in -a + b-.')
      22      et(04, 'illegal type for -a- in -a - b-.')
      23      et(05, 'incompatible types for -a- and -b- in -a - b-.')
      24      et(06, 'illegal type for -a- in -a div b-.')
      25      et(07, 'incompatible types for -a- and -b- in -a div b-.')
      26      et(08, 'illegal type for -a- in -a / b-.')
      27      et(09, 'incompatible types for -a- and -b- in -a / b-.')
      28      et(10, 'illegal type for -a- in -a mod b-.')
      29      et(11, 'incompatible types for -a- and -b- in -a mod b-.')
      30      et(12, 'illegal type for -a- in -a * b-.')
      31      et(13, 'incompatible operand types in -a * b-.')
      32      et(14, 'illegal type for -s- in -s with x-.')
      33      et(15, 'illegal type for -s- in -s with x-.')
      34      et(16, 'illegal type for -s- in -s less x-.')
      35      et(17, 'illegal type for -s- in -x from s-.')
      36      et(18, 'illegal type for -s- in -s lessf x-.')
      37      et(19, 'illegal type for -s- in -x in s-.')
      38      et(20, 'illegal type for -f- in -y := f(x)-.')
      39      et(21, 'illegal type for -f- in -y := f<>-.')
      40      et(22, 'illegal type for -f- in -f(x) := y-.')
      41      et(23, 'illegal type for -f- in -f<> := y-.')
      42      et(24, 'illegal type for -y- in -f<> := y-.')
      43      et(25, 'attempt to iterate over primitive type.')
      44      et(26, 'attempt to iterate over primitive type.')
      45      et(27, 'attempt to iterate over primitive type.')
      46      et(28, 'attempt to iterate over primitive type.')
      47      et(29, 'illegal type for -s- in -put(s)-.')
      48      et(30, 'illegal type for argument in -spec(t,s)-.')
      49      et(31, 'illegal type for -a- in -unspec(a)-.')
      50      et(32, 'illegal type for -x- in -# x-.')
      51      et(33, 'illegal type for -x- in -arb x-.')
      52      et(34, 'illegal type for -f- in -domain f-.')
      53      et(35, 'illegal type for -f- in -range f-.')
      54      et(36, 'illegal type for -s- in -y := s(i...j)-.')
      55      et(37, 'illegal type for -i- in -y := s(i...j)-.')
      56      et(38, 'illegal type for -j- in -y := s(i...j)-.')
      57      et(39, 'incompatible types for -f- and -y- in -f(x) := y-.')
      58      et(40, 'illegal type for -s- in -y := s(i ...)-.')
      59      et(41, 'illegal type for -s- in -s(i ...) := x-.')
      60      et(42, 'illegal operand type for -<- or ->-.')
      61      et(43, 'illegal operand type for -<=- or ->=-.')
      62      et(44, 'illegal type for -x- in -abs(x)-.')
      63      et(45, 'attempt to extract real value from non-real.')
      64      et(46, 'illegal type for -s1- in -s1 incs s2-.')
      65      et(47, 'illegal type for -s2- in -s1 incs s2-.')
      66      et(48, 'illegal type for -s- in -pow s-.')
      67      et(49, 'one operand must be a set in -x npow y-.')
      68      et(50, '-str- must be a character string in -getipp(str)-.')
      69      et(51, '-str- must be a character string in -getspp(str)-.')
      70      et(52, 'illegal type for -x- in -x ** y-.')
      71      et(53, 'illegal type for -y- in -x ** y-.')
      72      et(54, 'illegal type for -s- in -s(i...j) := x-.')
      73      et(55, 'illegal type for -i- in -s(i...j) := x-.')
      74      et(56, 'illegal type for -j- in -s(i...j) := x-.')
      75      et(57, 'incompatible types for -s- and -x- in -s(i...j) := x-.')
      76      et(58, 'illegal type for -x- in -ceil x-.')
      77      et(59, 'illegal type for -x- in -floor x-.')
      78      et(60, 'illegal type for -x- in -fix x-.')
      79      et(61, 'illegal type for -x- in -float x-.')
      80      et(62, 'illegal type for -t- in -x fromb t-.')
      81      et(63, 'illegal type for -t- in -x frome t-.')
      82      et(64, 'expect boolean result in test.')
      83      et(65, 'illegal type for -i- in -char i-.')
      84      et(66, 'illegal type for -x- in -x atan2 y-.')
      85      et(67, 'illegal type for -y- in -x atan2 y-.')
      86      et(68, 'illegal type for -x- in -acos x-.')
      87      et(69, 'illegal type for -x- in -asin x-.')
      88      et(70, 'illegal type for -x- in -atan x-.')
      89      et(71, 'illegal type for -x- in -cos x-.')
      90      et(72, 'illegal type for -x- in -exp x-.')
      91      et(73, 'illegal type for -x- in -log x-.')
      92      et(74, 'illegal type for -x- in -sin x-.')
      93      et(75, 'illegal type for -x- in -sqrt x-.')
      94      et(76, 'illegal type for -x- in -tan x-.')
      95      et(77, 'illegal type for -x- in -tanh x-.')
      96      et(78, 'illegal type for -x- in -random x-.')
      97      et(79, 'type check error: element of wrong plex base')
      98      et(80, 'type check error: expect element of plex base')
      99      et(81, 'type check error: expect atom')
     100
     101/esac/
     102
     103      call err_proc(msg, no);
     104
     105      macdrop(err_max)
     106
     107      end subr err_type;
       1 .=member errmisc
       2      subr err_misc(i);
       3
       4$ this subroutine prints run-time diagnostic messages of
       5$ miscellaneous nature.  -i- is the message number.
       6
       7
       8      size i(ps),             $ diagnostic message number
       9           msg(.sds. 80);     $ message text
      10
      11
      12      +*  err_max  =  57  **  $ number of error messages
      13
      14      if ( ^ (1 <= i & i <= err_max)) i = 0;
      15
      16      go to case(i) in 0 to err_max;
      17
      18      et(00, 'invalid error text index --- err_misc.')
      19      et(01, 'dividing by 0.')
      20      et(02, 'dividing by 0.')
      21      et(03, 'divide by 0.')
      22      et(04, 'integer overflow.')
      23      et(05, 'integer underflow.')
      24      et(06, 'divide by 0.')
      25      et(07, 'real overflow.')
      26      et(08, 'real underflow.')
      27      et(09, 'assertion failed.')
      28      et(10, 'map not single valued.')
      29      et(11, 'map not single valued.')
      30      et(12, 'map not single valued.')
      31      et(13, 'map not single valued.')
      32      et(14, 'map not single valued.')
      33      et(15, '-i- and/or -j- out of range in -s(i:j) := x-.')
      34      et(16, '-i- and/or -j- out of range in -s(i:j) := x-.')
      35      et(17, 'assigning illegal type.')
      36      et(18, 'integer out of range')
      37      et(19, 'expect integer.')
      38      et(20, 'illegal assignment.')
      39      et(21, 'illegal conversion to untyped integer.')
      40      et(22, 'illegal assignment to untyped integer.')
      41      et(23, 'illegal conversion to untyped real.')
      42      et(24, 'user abort.')
      43      et(25, 'illegal union on smaps.')
      44      et(26, '-s with x- declared smap has become multivalued');
      45      et(27, 'attempt to insert non-pair into map.')
      46      et(28, 'smap becoming multivalued.')
      47      et(29, 'f(x) on multivalued map.')
      48      et(30, '-x- is out of range in -f(x) := y-.')
      49      et(31, 'calling unsatisifed external procedure');
      50      et(32, '-i- is zero in -t(i) := x-.')
      51      et(33, '-i- is not an integer in -t(i) := x-.')
      52      et(34, 'illegal -f<>- on smap.')
      53      et(35, '-i- is zero in -y := s(i...j)-.')
      54      et(36, '-i- exceeds -j- in -y := s(i...j)-.')
      55      et(37, '-j- exceeds -#s- in -y := s(i...j)-.')
      56      et(38, '-j- exceeds -#s- in -y := s(i...j)-.')
      57      et(39, '-i- is zero in -s(i...j) := x-.')
      58      et(40, '-i- exceeds -j- in -s(i...j) := x-.')
      59      et(41, '-j- exceeds -#s- in -s(i...j) := x-.')
      60      et(42, '-i- is out of range in -f(i) := y- on mixed tuple.')
      61      et(43, 'illegal conversion.')
      62      et(44, 'illegal conversion from set to map.')
      63      et(45, 'found end-of-file while reading string.')
      64      et(46, 'invalid -s- in -dec s-.')
      65      et(47, 'invalid error message misc.47')
      66      et(48, 'execution terminated due to compile-time error.')
      67      et(49, 'invalid string length of -str- in -abs str-.')
      68      et(50, '-i- exceeds range of character set in -char i-.')
      69      et(51, 'expect boolean operand for -not-.')
      70      et(52, 'expect acos operand in domain.')
      71      et(53, 'expect asin operand in domain.')
      72      et(54, 'expect log operand in domain.')
      73      et(55, 'expect sqrt operand in domain.')
      74      et(56, 'attempt to expand mixed tuple beyond defined length.')
      75      et(57, 'attempt to read in malformed real value.')
      76
      77/esac/
      78
      79      call err_proc(msg, no);
      80
      81      macdrop(err_max)
      82
      83      end subr err_misc;
       1 .=member errval
       2      fnct err_val(fm);
       3
       4$ this routine returns an error value of the specified form.
       5
       6
       7$ variable declaration
       8
       9      size err_val(hs),       $ size of error value returned
      10           fm(ps);            $ form specifier
      11
      12
      13$ begin execution
      14
      15      if err_mode = err_full ! (err_mode = err_opt & fm = f_gen) then
      16          build_spec(err_val, t_error, codep);
      17
      18      else
      19          err_val = heap(ft_samp(fm));
      20
      21      end if err_mode;
      22
      23      end fnct err_val;
       1 .=member errproc
       2      subr err_proc(msg, abt);
       3
       4$ this routine does the error recovery depending on the
       5$ current value of -err_mode-, -err_count-, and -abt-.
       6
       7$ if no error checking is done (i.e. if -err_mode- = -err_off-),
       8$ this routine does nothing.  if partial or full error checking
       9$ is done, the current procedure name and statement number is
      10$ printed together with an error message.  the execution
      11$ is abnormally terminated if either the error count exceeds the
      12$ specified error limit, or the abort flag (-abt-) is set.
      13
      14$ -msg- is the error message as a self-defining string.
      15
      16$ -abt- is a flag indicating whether we want to force an
      17$ abnormal termination.
      18
      19
      20      size msg(sds_sz),       $ error message
      21           abt(1),            $ abort flag
      22           proc(sds_sz),      $ current procedure name
      23           stmt(ps);          $ current statement number
      24
      25
      26      err_count = err_count + 1;
      27
      28      if err_mode = err_part ! err_mode = err_full ! abt then
      29
smfb 181          put, skip;
      31          call contlpr(27, yes); $ start to echo to the terminal
      32          put ,'*** error';
      33          if runtime_flag then
      34              call find_stmt(proc, stmt, codep);
smfb 182              put ,' at ' :proc,a ,'.' :stmt,i;
smfb 183          end if;
smfb 184          put ,': ' :msg,a ,skip;
      42
      43          call contlpr(27, no);  $ stop to echo to the terminal
smfb 185          put, skip;
      45
      46          if snap_flag & runtime_flag & itotal ^= eitotal then
      47              eitotal = itotal;
      48              call snap(codep);
      49          end if;
      50
      51          if err_count > err_limit ! abt then
      52 .+s32        if (runtime_flag) call dumpds1;
      53              call ltlfin(1, 0); $ abnormally terminate execution
      54          end if err_count;
      55
      56      end if err_mode;
      57
      58      eitotal = itotal;
      59
      60
      61      end subr err_proc;
      62 ..part4
      63 .+part1.
      64
      65
       1 .=member snap
       2      subr snap(p);
       3
       4$ this routine prints the values of all variables, constants, and
       5$ temporaries used in the statement whose q2 code ends at heap(p).
       6
       7
       8      size p(ps);             $ pointer to last q2 instruction
       9
      10      size snap_no(ps);       $ counts number of calls to snap
      11      data snap_no = 0;
      12
      13      size p1(ps);            $ local copy of -p-
      14
      15
      16      if (p = 0) return;
      17
      18      snap_no = snap_no + 1;
      19
      20      put, skip(2), 'snap number ': snap_no, i, ':', skip;
      21
      22      p1 = p;
      23
      24      put, skip;
      25
      26      while codeop(p1) ^= q2_stmt;
      27          call dinst(p1);
      28
      29          if heap_valid then
      30              put, skip;
      31              call putvar('', codea1(p1));
      32              call putvar('', codea2(p1));
      33              call putvar('', codea3(p1));
      34              put, skip;
      35          end if;
      36
      37          p1 = p1 - inst_nw;
      38      end while;
      39
      40
      41      end subr snap;
       1 .=member putvar
       2      subr putvar(str, n);
       3
       4
       5      size str(sds_sz),       $ variable prefix
       6           n(ps);             $ heap pointer
       7
       8      size temp(hs);          $ heap sized temporary
       9      size junk(hs);          $ specifier returned by -print-
      10
      11      size var_id(sds_sz),    $ functions called
      12           bldstr(hs),
      13           print(hs);
      14
      15
      16      if ( ^ (sym_org <= n & n <= sym_end)) return;
      17
      18      push3(bldstr(str), bldstr(var_id(n, 0)), bldstr('='))
      19
      20      if otype(n) = t_proc then
      21          temp = bldstr('*** procedure ***');
      22          push1(temp)
      23
      24      elseif otype(n) = t_lab then
      25          temp = bldstr('*** label ***');
      26          push1(temp)
      27
      28      elseif ^ isprim(otype(n)) then
      29          if is_fbase(hform(value(n))) then
      30              temp = bldstr('*** base ***');
      31              push1(temp)
      32
      33          elseif is_fplex(hform(value(n))) then
      34              temp = bldstr('*** plex object ***');
      35              push1(temp);
      36
      37          else
      38              push1(heap(n))
      39          end if;
      40
      41      else
      42          push1(heap(n));
      43      end if;
      44
      45      junk = print(4);
      46
      47      free_stack(4);
      48
      49
      50      end subr putvar;
       1 .=member findstmt
       2      subr find_stmt(proc, stmt, p);
       3
       4$ this routine backtracks to the last stmt-quadruple,
       5$ and returns the procedure name and statement number.
       6
       7$ variable declarations
       8
       9      size proc(sds_sz),      $ current procedure name
      10           stmt(ps),          $ current statement
      11           p(ps),             $ local code pointer
      12           var_id(sds_sz);    $ returns symbol name as sds
      13
      14      size p1(ps);            $ local copy of p
      15
      16$ begin execution
      17
      18      p1 = p;
      19
      20      while p1 >= ca_org;     $ find previous stmt quadruple
      21
      22          if (codeop(p1) = q2_stmt) go to found;
      23          p1 = p1 - inst_nw;
      24      end while;
      25
      26      proc = '***';
      27      stmt = 0;
      28
      29      return;
      30
      31/found/                       $ extract procedure name and stmt #
      32
      33      proc = var_id(codea1(p1), 0);
      34      stmt = codea2(p1);
      35
      36      return;
      37
      38      end subr find_stmt;
      39
      40
      41
      42
      43
      44 ..part1
      45 .+part4.
      46
      47
      48
      49
      50
       1 .=member libterm
       2      subr libterm(time);
       3
       4$ this routine is called for normal library termination.
       5
       6      size time(ws);   $ total execution time
       7
       8 if lcs_flag then
       9    put ,skip(2)
      10        ,'run time m-sec' ,column(20)
      11        :time,i
      12        ,skip
      13        ,'statements' ,column(20)
      14        :stm_exe,i
      15        ,skip;
      16    if stm_exe then
      17        put ,'m-sec / stmt' ,column(20)
      18            :((time)/stm_exe),i ,skip;
      19    end if;
      20    if itotal then
      21        put ,'instructions' ,column(20)
      22            :itotal,i
      23            ,skip
      24            ,'mc-sec / inst' ,column(20)
      25            :(ifix(float(time)*1000.0/float(itotal))),i
      26            ,skip;
      27    end if;
      28    put ,'initial heap' ,column(20)
      29        :init_heap_len,i ,skip
      30        ,'final heap' ,column(20)
      31        :h_lim,i ,skip;
      32   if grb_tot then $ if any collections
      33        put ,'regenerations' ,column(20)
      34            :grb_tot,i ,skip
      35            ,'regen time m-sec' ,column(20)
      36            :(grb_tim),i ,skip
      37            ,'words recovered' ,column(20)
      38            :(grb_rec),i
      39            ,skip
      40            ,'words / regen' ,column(20)
      41            :((grb_rec)/grb_tot),i
      42            ,skip;
      43    end if;
      44  end if;
      45
      46 .+st call put_stat;
      47      call ltlfin(0, 0);
      48
      49
      50      end subr libterm;
       1 .=member fixcas
       2 .+mc.
       3      subr fixcas(socase); $ adjust case for result strings
       4      size socase(ps);
       5      size ss(ssz);
       6      size t(ps);
       7      size tp(ps);
       8      size i(ps);
       9      size c(ps);
      10      size ctlc(cs); $ folds to lower case
      11      size ctuc(cs);  $ folds to upper case
      12
      13      if  (socase=0) return;
      14      do  t = t_min to t_max+1;
      15          tp = s_types(t); $ get type result specifier
      16          if (is_om(tp)) cont do;
      17          ss = value(tp);
      18          do i = 1 to ss_len(ss);
      19              c = icchar(ss, i); $ get character
      20              if socase=1 then c = ctlc(c); $ fold to proper case.
      21              else  c = ctuc(c);  end if;
      22              icchar(ss, i) = c;
      23           end do;
      24      end do;
      25      end subr fixcas;
      26 ..mc
       1 .=member putstat
       2
       3
       4
       5 ..part4
       6 .+part1.
       7
       8 .+st.
       9
      10
      11
      12
      13      subr put_stat;
      14
      15$ this is the main routine for priniting out statistics. it
      16$ prints out all the statistics we have collected on a statement
      17$ by statement basis, then calls put_freq to print the frequency
      18$ of each q2 instruction.
      19
      20$ the measurement package works in two ways, depending on whether
      21$ the 'sti' conditional assembly option has been turned on:
      22
      23$ sti off:    the statistics for total library time include time
      24$             spent in the interpreter.
      25
      26$ sti on:     the statistics for total library time do not include
      27$             the time spent in the interpreter.
      28
      29$ in the second mode it is possible to compute the percentage of time
      30$ spent in nubbins. this is done using the variables ntotal(total
      31$ nubbin time) and gtotal(grand total).
      32
      33
      34$ variable declarations
      35
      36      size i(ps),             $ loop indices
      37           j(ps);
      38
      39      size st(hs);      $ value of statistic
      40
      41$ the array 'st_column' gives the column for printing each class of
      42$ statistics. note that the macros st_xxx are arranged so that time
      43$ measurements come first. however the statistics are printed with
      44$ the frequency count first.
      45
      46      size st_column(ps);
      47      dims st_column(st_max);
      48
      49      data st_column(st_nubbin) = 030:
      50           st_column(st_lib)    = 040:
      51           st_column(st_nelt)   = 050:
      52           st_column(st_hash)   = 060:
      53           st_column(st_conv)   = 070:
      54           st_column(st_cset)   = 080:
      55           st_column(st_copy)   = 090:
      56           st_column(st_garb)   = 100:
      57           st_column(st_space)  = 110:
      58           st_column(st_count)  = 020;
      59
      60      size st_name(.sds. 9);  $ gives names of statistics
      61      dims st_name(st_max);
      62
      63      data st_name(st_nubbin) = 'nubbins':
      64           st_name(st_lib)    = 'library':
      65           st_name(st_nelt)   = 'ok nelt':
      66           st_name(st_hash)   = 'ok hash':
      67           st_name(st_conv)   = 'gen conv':
      68           st_name(st_cset)   = 'set-map':
      69           st_name(st_copy)   = 'copy':
      70           st_name(st_garb)   = 'garb':
      71           st_name(st_space)  = 'space':
      72           st_name(st_count)  = 'count';
      73
      74      size lines(ps),         $ lines per page
      75           total(ws);       $ total for this statement
      76
      77 .+sti.
      78
      79      size gtotal(ws),     $ grand total time
      80           ntotal(ws);     $ nubbin total time
      81 ..sti
      82
      83      +*  lines_max  =  55  **  $ print 55 lines/page
      84
      85
      86$ begin execution
      87
      88      if (st_no = 0) return;  $ not saving statistics
      89
      90      call stltitle(yes, '      execution statistics');
      91
      92      lines = lines_max;   $ to force new heading
      93
      94 .+sti gtotal = 0;
      95 .+sti ntotal = 0;
      96
      97      do i = st_lo to st_hi;
      98          lines = lines + 1;
      99
     100          if lines > lines_max then
     101              lines = 1;
     102              put, column(007), 'statement';
     103
     104              do j = 1 to st_max;
     105                  put, column(st_column(j)): st_name(j), a;
     106              end do;
     107
     108              put, column(120), 'total';
     109
     110              put, skip(2);
     111          end if;
     112
     113          total = 0;
     114
     115          put, column(007): i, i;
     116
     117          do j = 1 to st_max;
     118              put, column(st_column(j));
     119              st = stat_tot(i, j);
     120
     121              if st = om_int then
     122                  put, '*';
     123
     124              else
     125                  if j < st_garb then
     126 .+sti                gtotal = gtotal + st;
     127 .+sti                if (j = st_nubbin) ntotal = ntotal + st;
     128
     129                      st     = st / stat_tot(i, st_count);
     130                      total  = total + st;
     131                  end if;
     132
     133                  put: st, i;
     134              end if;
     135          end do;
     136
     137          put, column(120): total, i;
     138
     139          if lines = lines_max then
     140              put, page;
     141          else
     142              put, skip;
     143          end if;
     144      end do;
     145
     146
     147 .+sti.
     148
     149      put, skip, column(7), 'percentage of time in nubbins: ':
     150                 ntotal * 100 / gtotal, i, skip(2);
     151
     152 ..sti
     153
     154$ print frequencies of various q2 opcodes.
     155
     156      call put_freq;
     157
     158      end subr put_stat;
     159
     160
     161
     162
     163 ..st
     164
     165 ..part1
     166 .+part4.
     167
     168
     169
       1 .=member usratp
       2      subr usratp;
       3
       4$ this routine is called whenever the operating system detects
       5$ an error such as address exception, overflow, etc. we issue
       6$ an error message, dump the heap, and return to the system.
       7
       8 .+tr monitor noentry;        $ disable entry trace
       9
      10
      11      call remarkl(' abnormal termination.');
      12
      13      put, skip(4), '*** fatal error detected by operating system ***',
      14           skip(4), 'code pointer:    ': codep, i,
      15           skip(1), 'final heap size: ': h_lim, i,
      16           skip(4);
      17
      18      call dumpio;
      19      call dumpds1;
      20
      21      if (snap_flag) call snap(codep);
      22
      23
      24      end subr usratp;
       1 .=member dumpds1
       2
       3 .+tr notrace entry;
       4
       5      subr dumpds1;
       6
       7$ this routine is called whenever a dynamic storage dump is requested.
       8$ rather than dump the heap, we write it onto a scratch file for later
       9$ dumping. this way the dump routines are not in core during the
      10$ execution of a program.
      11
      12$ the environment is written onto a file 'dump'. note that we reuse
      13$ the file identifier for the q2_file since this file is allocated
      14$ a fairly large buffer.
      15
      16      size dumpno(ps);        $ dump number
      17      data dumpno = 0;
      18
      19      size dump_title(.sds. filenamlen);   $ title of dump file
      20
      21
      22      if dumpno = 0 then      $ initialize file
      23
      24          call getspp(dump_title, 'dump=0/');
      25          file q2_file access = write, title = dump_title;
      26      end if;
      27
      28      dumpno = dumpno + 1;
      29      if (dump_title .seq. '0') return;
      30$
      31$  write check word and date stamp on dump file
      32$
      33      write q2_file,
      34          check_word;
      35
      36      write q2_file,
      37          date_stamp;
      38
      39      call wrheap(q2_file);
      40
      41
      42      end subr dumpds1;
       1 .=member opnam1
       2
       3 ..part4
       4 .+part1.
       5
       6
       7 .+tr notrace entry;          $ do not trace entry for dump routines
       8
       9      subr opnam1;
      10
      11$ this routine declares and initializes a global array 'opname1'
      12$ mapping the first half of the q2 opcodes into strings giving their
      13$ names.
      14
      15      nameset nsopn1;
      16
      17          size opname1(.sds. 8);
      18          dims opname1(q2_asn - 1);
      19
      20          data opname1(q2_copy)      =   'copy':
      21               opname1(q2_ccopy)     =   'ccopy':
      22               opname1(q2_share)     =   'share':
      23               opname1(q2_add)       =   'add':
      24               opname1(q2_div)       =   'div':
      25               opname1(q2_mult)      =   'mult':
      26               opname1(q2_slash)     =   'slash':
      27               opname1(q2_sub)       =   'sub':
      28               opname1(q2_mod)       =   'mod':
      29               opname1(q2_exp)       =   'exp':
      30               opname1(q2_addi)      =   'addi':
      31               opname1(q2_inci)      =   'inci':
      32               opname1(q2_divi)      =   'divi':
      33               opname1(q2_modi)      =   'modi':
      34               opname1(q2_multi)     =   'multi':
      35               opname1(q2_slashi)    =   'slashi':
      36               opname1(q2_subi)      =   'subi':
      37               opname1(q2_shiftl)    =   'shiftl':
      38               opname1(q2_shiftr)    =   'shiftr':
      39               opname1(q2_addui)     =   'addui':
      40               opname1(q2_incui)     =   'incui':
      41               opname1(q2_divui)     =   'divui':
      42               opname1(q2_multui)    =   'multui':
      43               opname1(q2_modui)     =   'modui':
      44               opname1(q2_slashui)   =   'slashui':
      45               opname1(q2_subui)     =   'subui':
      46               opname1(q2_shiftlui)  =   'shiftlui':
      47               opname1(q2_shiftrui)  =   'shiftrui':
      48               opname1(q2_over)      =   'over':
      49               opname1(q2_under)     =   'under':
      50               opname1(q2_addur)     =   'addur':
      51               opname1(q2_multur)    =   'multur':
      52               opname1(q2_subur)     =   'subur':
      53               opname1(q2_slashur)   =   'slashur':
      54               opname1(q2_rover)     =   'rover':
      55               opname1(q2_runder)    =   'runder':
      56               opname1(q2_addli)     =   'addli':
      57               opname1(q2_addtup)    =   'addtup':
      58               opname1(q2_addstr)    =   'addstr':
      59               opname1(q2_diffli)    =   'diffli':
      60               opname1(q2_divli)     =   'divli':
      61               opname1(q2_modli)     =   'modli':
      62               opname1(q2_atan2)     =   'atan2':
      63               opname1(q2_multli)    =   'multli':
      64               opname1(q2_union)     =   'union':
      65               opname1(q2_unset)     =   'unset':
      66               opname1(q2_unlset)    =   'unlset':
      67               opname1(q2_unrset)    =   'unrset':
      68               opname1(q2_inter)     =   'inter':
      69               opname1(q2_inset)     =   'inset':
      70               opname1(q2_inlset)    =   'inlset':
      71               opname1(q2_inrset)    =   'inrset':
      72               opname1(q2_setdiff)   =   'setdiff':
      73               opname1(q2_difset)    =   'difset':
      74               opname1(q2_diflset)   =   'diflset':
      75               opname1(q2_difrset)   =   'difrset':
      76               opname1(q2_setmod)    =   'setmod':
      77               opname1(q2_with)      =   'with':
      78               opname1(q2_withs)     =   'withs':
      79               opname1(q2_withus)    =   'withus':
      80               opname1(q2_withls)    =   'withls':
      81               opname1(q2_withrs)    =   'withrs':
      82               opname1(q2_witht)     =   'witht':
      83               opname1(q2_withut)    =   'withut':
      84               opname1(q2_withm)     =   'withm':
      85               opname1(q2_less)      =   'less':
      86               opname1(q2_lessls)    =   'lessls':
      87               opname1(q2_lessrs)    =   'lessrs':
      88               opname1(q2_lessf)     =   'lessf':
      89               opname1(q2_lessflm)   =   'lessflm':
      90               opname1(q2_lessfrm)   =   'lessfrm':
      91               opname1(q2_from)      =   'from':
      92               opname1(q2_froms)     =   'froms':
      93               opname1(q2_fromb)     =   'fromb':
      94               opname1(q2_frombt)    =   'frombt':
      95               opname1(q2_frome)     =   'frome':
      96               opname1(q2_fromet)    =   'fromet':
      97               opname1(q2_mini)      =   'mini':
      98               opname1(q2_minui)     =   'minui':
      99               opname1(q2_minur)     =   'minur':
     100               opname1(q2_min)       =   'min':
     101               opname1(q2_maxi)      =   'maxi':
     102               opname1(q2_maxui)     =   'maxui':
     103               opname1(q2_maxur)     =   'maxur':
     104               opname1(q2_max)       =   'max':
     105               opname1(q2_npow)      =   'npow':
     106               opname1(q2_eq1)       =   'eq1':
     107               opname1(q2_eqv)       =   'eqv':
     108               opname1(q2_eq)        =   'eq':
     109               opname1(q2_zr)        =   'zr':
     110               opname1(q2_eqom)      =   'eqom':
     111               opname1(q2_eqnl)      =   'eqnl':
     112               opname1(q2_eqnult)    =   'eqnult':
     113               opname1(q2_gei)       =   'gei':
     114               opname1(q2_geui)      =   'geui':
     115               opname1(q2_geur)      =   'geur':
     116               opname1(q2_ge)        =   'ge':
     117               opname1(q2_incs)      =   'incs':
     118               opname1(q2_in)        =   'in':
     119               opname1(q2_ins)       =   'ins':
     120               opname1(q2_inu)       =   'inu':
     121               opname1(q2_inl)       =   'inl':
     122               opname1(q2_inr)       =   'inr':
     123               opname1(q2_lti)       =   'lti':
     124               opname1(q2_ltui)      =   'ltui':
     125               opname1(q2_ltur)      =   'ltur':
     126               opname1(q2_lt)        =   'lt':
     127               opname1(q2_ne1)       =   'ne1':
     128               opname1(q2_nev)       =   'nev':
     129               opname1(q2_ne)        =   'ne':
     130               opname1(q2_nz)        =   'nz':
     131               opname1(q2_neom)      =   'neom':
     132               opname1(q2_nenl)      =   'nenl':
     133               opname1(q2_nenult)    =   'nenult':
     134               opname1(q2_nincs)     =   'nincs':
     135               opname1(q2_nin)       =   'nin':
     136               opname1(q2_nins)      =   'nins':
     137               opname1(q2_ninu)      =   'ninu':
     138               opname1(q2_ninl)      =   'ninl':
     139               opname1(q2_ninr)      =   'ninr':
     140               opname1(q2_not)       =   'not':
     141               opname1(q2_even)      =   'even':
     142               opname1(q2_eveni)     =   'eveni':
     143               opname1(q2_evenui)    =   'evenui':
     144               opname1(q2_odd)       =   'odd':
     145               opname1(q2_oddi)      =   'oddi':
     146               opname1(q2_oddui)     =   'oddui':
     147               opname1(q2_isint)     =   'isint':
     148               opname1(q2_isreal)    =   'isreal':
     149               opname1(q2_isstr)     =   'isstr':
     150               opname1(q2_isbool)    =   'isbool':
     151               opname1(q2_isatom)    =   'isatom':
     152               opname1(q2_istup)     =   'istup':
     153               opname1(q2_isset)     =   'isset':
     154               opname1(q2_ismap)     =   'ismap':
     155               opname1(q2_arb)       =   'arb':
     156               opname1(q2_arbs)      =   'arbs':
     157               opname1(q2_arbt)      =   'arbt':
     158               opname1(q2_arbut)     =   'arbut':
     159               opname1(q2_domain)    =   'domain':
     160               opname1(q2_range)     =   'range':
     161               opname1(q2_pow)       =   'pow':
     162               opname1(q2_neltst)    =   'neltst':
     163               opname1(q2_neltok)    =   'neltok':
     164               opname1(q2_neltic)    =   'neltic':
     165               opname1(q2_neltc)     =   'neltc':
     166               opname1(q2_nelt)      =   'nelt':
     167               opname1(q2_abs)       =   'abs':
     168               opname1(q2_absi)      =   'absi':
     169               opname1(q2_absui)     =   'absui':
     170               opname1(q2_absur)     =   'absur':
     171               opname1(q2_char)      =   'char':
     172               opname1(q2_ceil)      =   'ceil':
     173               opname1(q2_ceilur)    =   'ceilur':
     174               opname1(q2_floor)     =   'floor':
     175               opname1(q2_floorur)   =   'floorur':
     176               opname1(q2_fix)       =   'fix':
     177               opname1(q2_fixur)     =   'fixur':
     178               opname1(q2_float)     =   'float':
     179               opname1(q2_floatui)   =   'floatui':
     180               opname1(q2_asrt)      =   'asrt':
smfb 186               opname1(q2_ifasrt)    =   'ifasrt':
     181               opname1(q2_val)       =   'val':
     182               opname1(q2_rand)      =   'rand':
     183               opname1(q2_sin)       =   'sin':
     184               opname1(q2_cos)       =   'cos':
     185               opname1(q2_tan)       =   'tan':
     186               opname1(q2_arcsin)    =   'arcsin':
     187               opname1(q2_arccos)    =   'arccos':
     188               opname1(q2_arctan)    =   'arctan':
     189               opname1(q2_tanh)      =   'tanh':
     190               opname1(q2_expf)      =   'expf':
     191               opname1(q2_log)       =   'log':
     192               opname1(q2_sqrt)      =   'sqrt':
     193               opname1(q2_type)      =   'type':
     194               opname1(q2_umini)     =   'umini':
     195               opname1(q2_uminui)    =   'uminui':
     196               opname1(q2_uminur)    =   'uminur':
     197               opname1(q2_umin)      =   'umin':
     198               opname1(q2_str)       =   'str':
     199               opname1(q2_sign)      =   'sign':
     200               opname1(q2_end)       =   'end':
     201               opname1(q2_subst)     =   'subst':
     202               opname1(q2_newat1)    =   'newat1':
     203               opname1(q2_newat2)    =   'newat2':
     204               opname1(q2_time)      =   'time':
     205               opname1(q2_date)      =   'date':
     206               opname1(q2_na)        =   'na':
     207               opname1(q2_set1)      =   'set1':
     208               opname1(q2_set2)      =   'set2':
     209               opname1(q2_tup1)      =   'tup1':
     210               opname1(q2_tup2)      =   'tup2':
     211               opname1(q2_of)        =   'of':
     212               opname1(q2_ofcs)      =   'ofcs':
     213               opname1(q2_ofcl)      =   'ofcl':
     214               opname1(q2_oftoks)    =   'oftoks':
     215               opname1(q2_oftok)     =   'oftok':
     216               opname1(q2_oft)       =   'oft':
     217               opname1(q2_ofts)      =   'ofts':
     218               opname1(q2_ofusms)    =   'ofusms':
     219               opname1(q2_ofusm)     =   'ofusm':
     220               opname1(q2_ofums)     =   'ofums':
     221               opname1(q2_ofum)      =   'ofum':
     222               opname1(q2_oflsms)    =   'oflsms':
     223               opname1(q2_oflsm)     =   'oflsm':
     224               opname1(q2_oflms)     =   'oflms':
     225               opname1(q2_oflm)      =   'oflm':
     226               opname1(q2_ofrsm)     =   'ofrsm':
     227               opname1(q2_ofrsms)    =   'ofrsms':
     228               opname1(q2_ofrm)      =   'ofrm':
     229               opname1(q2_ofrms)     =   'ofrms':
     230               opname1(q2_ofa)       =   'ofa':
     231               opname1(q2_ofaumms)   =   'ofaumms':
     232               opname1(q2_ofaumm)    =   'ofaumm':
     233               opname1(q2_ofalmms)   =   'ofalmms':
     234               opname1(q2_ofalmm)    =   'ofalmm':
     235               opname1(q2_ofarmm)    =   'ofarmm':
     236               opname1(q2_ofarmms)   =   'ofarmms';
     237      end nameset;
     238
     239
     240      end subr opnam1;
       1 .=member opnam2
       2      subr opnam2;
       3
       4$ this routine is similar to opnam1, but initializes an array for the
       5$ second half of the opcodes.
       6
       7      nameset nsopn2;
       8
       9      +*  opname2(i) = a_opname2(i - q2_asn + 1)  **
      10
      11      size a_opname2(.sds. 8);
      12      dims a_opname2(q2_maximum - q2_asn + 1);
      13
      14          data opname2(q2_asn)       =   'asn':
      15               opname2(q2_asnsb)     =   'asnsb':
      16               opname2(q2_asnnl)     =   'asnnl':
      17               opname2(q2_asnnult)   =   'asnnult':
      18               opname2(q2_push)      =   'push':
      19               opname2(q2_pop)       =   'pop':
      20               opname2(q2_push1)     =   'push1':
      21               opname2(q2_push1u)    =   'push1u':
      22               opname2(q2_pop1)      =   'pop1':
      23               opname2(q2_free)      =   'free':
      24               opname2(q2_free1)     =   'free1':
      25               opname2(q2_sof)       =   'sof':
      26               opname2(q2_sofcs)     =   'sofcs':
      27               opname2(q2_sofcl)     =   'sofcl':
      28               opname2(q2_softok)    =   'softok':
      29               opname2(q2_soft)      =   'soft':
      30               opname2(q2_soflm)     =   'soflm':
      31               opname2(q2_sofrm)     =   'sofrm':
      32               opname2(q2_sofa)      =   'sofa':
      33               opname2(q2_sofas)     =   'sofas':
      34               opname2(q2_sofalmm)   =   'sofalmm':
      35               opname2(q2_sofarmm)   =   'sofarmm':
      36               opname2(q2_send)      =   'send':
      37               opname2(q2_ssubst)    =   'ssubst':
      38               opname2(q2_eqform1)   =   'eqform1':
      39               opname2(q2_eqform2)   =   'eqform2':
      40               opname2(q2_eqform3)   =   'eqform3':
      41               opname2(q2_eqform4)   =   'eqform4':
      42               opname2(q2_convert)   =   'convert':
      43               opname2(q2_locate)    =   'locate':
      44               opname2(q2_deref1)    =   'deref1':
      45               opname2(q2_deref)     =   'deref':
      46               opname2(q2_checktp)   =   'checktp':
      47               opname2(q2_checki1)   =   'checki1':
      48               opname2(q2_checki2)   =   'checki2':
      49               opname2(q2_chkatom)   =   'chkatom':
      50               opname2(q2_tint1)     =   'tint1':
      51               opname2(q2_tint2)     =   'tint2':
      52               opname2(q2_treal)     =   'treal':
      53               opname2(q2_uint1)     =   'uint1':
      54               opname2(q2_uint2)     =   'uint2':
      55               opname2(q2_ureal1)    =   'ureal1':
      56               opname2(q2_ureal2)    =   'ureal2':
      57               opname2(q2_goto)      =   'goto':
      58               opname2(q2_caset)     =   'caset':
      59               opname2(q2_caselsm)   =   'caselsm':
      60               opname2(q2_casersm)   =   'casersm':
      61               opname2(q2_caseusm)   =   'caseusm':
      62               opname2(q2_goeq1)     =   'goeq1':
      63               opname2(q2_goeqv)     =   'goeqv':
      64               opname2(q2_goeq)      =   'goeq':
      65               opname2(q2_gozr)      =   'gozr':
      66               opname2(q2_gotrue)    =   'gotrue':
      67               opname2(q2_gofalse)   =   'gofalse':
      68               opname2(q2_goom)      =   'goom':
      69               opname2(q2_gonl)      =   'gonl':
      70               opname2(q2_gonult)    =   'gonult':
      71               opname2(q2_gogei)     =   'gogei':
      72               opname2(q2_gogeui)    =   'gogeui':
      73               opname2(q2_gogeur)    =   'gogeur':
      74               opname2(q2_goge)      =   'goge':
      75               opname2(q2_goincs)    =   'goincs':
      76               opname2(q2_goin)      =   'goin':
      77               opname2(q2_goins)     =   'goins':
      78               opname2(q2_goinus)    =   'goinus':
      79               opname2(q2_goinl)     =   'goinl':
      80               opname2(q2_goinr)     =   'goinr':
      81               opname2(q2_golti)     =   'golti':
      82               opname2(q2_goltui)    =   'goltui':
      83               opname2(q2_goltur)    =   'goltur':
      84               opname2(q2_golt)      =   'golt':
      85               opname2(q2_gone1)     =   'gone1':
      86               opname2(q2_gonev)     =   'gonev':
      87               opname2(q2_gone)      =   'gone':
      88               opname2(q2_gonz)      =   'gonz':
      89               opname2(q2_gonom)     =   'gonom':
      90               opname2(q2_gonnl)     =   'gonnl':
      91               opname2(q2_gonnult)   =   'gonnult':
      92               opname2(q2_gonincs)   =   'gonincs':
      93               opname2(q2_gonin)     =   'gonin':
      94               opname2(q2_gonins)    =   'gonins':
      95               opname2(q2_goninus)   =   'goninus':
      96               opname2(q2_goninl)    =   'goninl':
      97               opname2(q2_goninr)    =   'goninr':
      98               opname2(q2_inexts)    =   'inexts':
      99               opname2(q2_inextt)    =   'inextt':
     100               opname2(q2_inext)     =   'inext':
     101               opname2(q2_nextt)     =   'nextt':
     102               opname2(q2_nextut)    =   'nextut':
     103               opname2(q2_nextus)    =   'nextus':
     104               opname2(q2_nextls)    =   'nextls':
     105               opname2(q2_nextrs)    =   'nextrs':
     106               opname2(q2_next)      =   'next':
     107               opname2(q2_nexts)     =   'nexts':
     108               opname2(q2_inextd)    =   'inextd':
     109               opname2(q2_nextd)     =   'nextd':
     110               opname2(q2_call)      =   'call':
     111               opname2(q2_ucall)     =   'ucall':
     112               opname2(q2_retn)      =   'retn':
     113               opname2(q2_lab)       =   'lab':
     114               opname2(q2_tag)       =   'tag':
     115               opname2(q2_mentry)    =   'mentry':
     116               opname2(q2_pentry)    =   'pentry':
     117               opname2(q2_swap)      =   'swap':
     118               opname2(q2_savel)     =   'savel':
     119               opname2(q2_loadp)     =   'loadp':
     120               opname2(q2_resetp)    =   'resetp':
     121               opname2(q2_clearl)    =   'clearl':
     122               opname2(q2_resetl)    =   'resetl':
     123               opname2(q2_entry)     =   'entry':
     124               opname2(q2_exit)      =   'exit':
     125               opname2(q2_bcall)     =   'bcall':
     126               opname2(q2_bpop1)     =   'bpop1':
     127               opname2(q2_bpopu1)    =   'bpopu1':
     128               opname2(q2_bfree)     =   'bfree':
     129               opname2(q2_ok)        =   'ok':
     130               opname2(q2_lev)       =   'lev':
     131               opname2(q2_fail1)     =   'fail1':
     132               opname2(q2_dexit)     =   'dexit':
     133               opname2(q2_fail2)     =   'fail2':
     134               opname2(q2_undo)      =   'undo':
     135               opname2(q2_succeed)   =   'succeed':
     136               opname2(q2_open)      =   'open':
     137               opname2(q2_close)     =   'close':
     138               opname2(q2_print)     =   'print':
     139               opname2(q2_read)      =   'read':
     140               opname2(q2_printa)    =   'printa':
     141               opname2(q2_reada)     =   'reada':
     142               opname2(q2_get)       =   'get':
     143               opname2(q2_put)       =   'put':
     144               opname2(q2_getb)      =   'getb':
     145               opname2(q2_putb)      =   'putb':
     146               opname2(q2_getk)      =   'getk':
     147               opname2(q2_putk)      =   'putk':
     148               opname2(q2_getf)      =   'getf':
     149               opname2(q2_callf)     =   'callf':
     150               opname2(q2_putf)      =   'putf':
     151               opname2(q2_rewind)    =   'rewind':
     152               opname2(q2_eof)       =   'eof':
     153               opname2(q2_eject)     =   'eject':
     154               opname2(q2_titl)      =   'titl':
     155               opname2(q2_getipp)    =   'getipp':
     156               opname2(q2_getspp)    =   'getspp':
     157               opname2(q2_getem)     =   'getem':
     158               opname2(q2_setem)     =   'setem':
     159               opname2(q2_host)      =   'host':
     160               opname2(q2_span)      =   'span':
     161               opname2(q2_break)     =   'break':
     162               opname2(q2_match)     =   'match':
     163               opname2(q2_lpad)      =   'lpad':
     164               opname2(q2_len)       =   'len':
     165               opname2(q2_any)       =   'any':
     166               opname2(q2_notany)    =   'notany':
     167               opname2(q2_rspan)     =   'rspan':
     168               opname2(q2_rbreak)    =   'rbreak':
     169               opname2(q2_rmatch)    =   'rmatch':
     170               opname2(q2_rpad)      =   'rpad':
     171               opname2(q2_rlen)      =   'rlen':
     172               opname2(q2_rany)      =   'rany':
     173               opname2(q2_rnotany)   =   'rnotany':
     174               opname2(q2_tre)       =   'tre':
     175               opname2(q2_notre)     =   'notre':
     176               opname2(q2_trcstmts)  =   'trcstmts':
smfb 187               opname2(q2_trccalls)  =   'trccalls':
smfb 188               opname2(q2_trcsym)    =   'trcsym':
     177               opname2(q2_trc)       =   'trc':
     178               opname2(q2_notrc)     =   'notrc':
     179               opname2(q2_trg)       =   'trg':
     180               opname2(q2_notrg)     =   'notrg':
     181               opname2(q2_gdump)     =   'gdump':
     182               opname2(q2_nogdump)   =   'nogdump':
     183               opname2(q2_dump)      =   'dump':
     184               opname2(q2_garb)      =   'garb':
     185               opname2(q2_stmt)      =   'stmt':
     186               opname2(q2_abort)     =   'abort':
     187               opname2(q2_error)     =   'error':
     188               opname2(q2_stop)      =   'stop':
     189               opname2(q2_noop)      =   'noop';
     190      end nameset;
     191
     192
     193      end subr opnam2;
     194
     195
       1 .=member dinst
       1 .=member opname
       2      fnct opname(op);
       3$
       4$ return the name of an opcode as an sds string.  the name is in either
       5$ opnam1 or opnam2 above.
       6$
       7      size op(ps);            $ opcode
       8      size opname(sds_sz);    $ string returned
       9
      10      size j(ps);             $ loop index
      11      size init(1);           $ flags initial entry
      12      data init = yes;
      13
      14      access nsopn1, nsopn2;
      15
      16
      17      if init then            $ call opnam1 and opnam2 to force load
      18          call opnam1; call opnam2;
      19          init = no;
      20      end if;
      21
      22      if q2_minimum <= op & op < q2_asn then
      23          opname = opname1(op);
      24      elseif op <= q2_maximum then
      25          opname = opname2(op);
      26      else
      27          slen opname = 0;
      28      end if;
      29
      30      do j = slen opname to 1 by -1;
      31          if (.ch. j, opname ^= 1r ) quit do;
      32          slen opname = j-1;
      33      end do;
      34
      35
      36      end fnct opname;
      37      subr dinst(p);
      38
      39$ this routine dumps an interpreter instruction at heap(p).
      40$ it uses the two tables -opname1- and -opname2- to map the
      41$ q2 opcodes to their names.  these two tables are initialized
      42$ in the routines -opnam1- and -opnam2-, resp.
      43
      44      size p(ps);             $ heap pointer
      45
      46      size op(ps);            $ opcode
      47      size arg(ps);           $ current argument
      48      size opn(sds_sz);       $ current opcode name
      49
      50      size opname(sds_sz);    $ return opcode name as sds
      51      size var_id(sds_sz);    $ returns symbol name as sds
      52
      53
      54      put, column(7): p, i, column(16);
      55
      56      op = codeop(p);
      57
      58      opn = opname(op);
      59      if slen opn = 0 then put :op ,i; else put :opn ,a; end if;
      60
      61      arg = codea1(p);
      62      if sym_org <= arg & arg <= sym_end then
      63          put, column(30): var_id(arg, 10), a;
      64      else
      65          put, column(30): arg, i;
      66      end if;
      67
      68      arg = codea2(p);
      69      if sym_org <= arg & arg <= sym_end & op ^= q2_stmt then
      70          put, column(45): var_id(arg, 10), a;
      71      else
      72          put, column(45): arg, i;
      73      end if;
      74
      75      arg = codea3(p);
      76      if sym_org <= arg & arg <= sym_end & op ^= q2_stmt then
      77          put, column(60): var_id(arg, 10), a;
      78      else
      79          put, column(60): arg, i;
      80      end if;
      81
      82
      83      put, column(75): codea4(p), i(1);
      84
      85      put, skip;
      86
      87
      88      end subr dinst;
      89
      90 ..part1
      91 .+part4.
       1 .=member varid
       2      fnct var_id(p, n);
       3
       4$ this function returns the name of a symbol table entry given
       5$ a pointer to it. the result is an sds string with a maximum
       6$ length of 'toklen_lim'.
       7
       8$ the routines arguments are:
       9
      10$ p:    a symbol table pointer
      11
      12$ n:    desired length for the result. if n is zero we return
      13$       the original variable name. otherwise we pad or truncate
      14$       it to n characters.
      15
      16
      17      size p(ps),   $ symbol table poiner
      18           n(ps);   $ length
      19
      20      size var_id(sds_sz);
      21
smfa  61      size len(ps);           $ actual length
smfa  62      size ss1(ssz);          $ string specifier
smfa  63      size word(ps);          $ pointer to word in long char block
smfa  64      size offs(ps);          $ origin in current word
smfa  65      size j(ps);             $ loop index
smfa  66      size temp(ps);          $ temporary
smfa  67
      26
      27
      28      if ( ^ (sym_org <= p & p <= sym_end)) go to error;
      29
      30
smfa  80      if n = 0 then
smfa  81          if 0 < rn_indx(p) & rn_indx(p) <= nelt(value(s_rnames)) then
smfa  82              len = rn_len(p);
smfa  83          else
smfa  84              len = 7;
smfa  85          end if;
smfa  86      else
smfa  87          len = n;
smfa  88      end if;
smfa  89
smfa  90      var_id = 0; sorg var_id = sds_sz+1; slen var_id = len;
smfa  91
smfa  92      if rn_indx(p) = 0 then
smfa  93          do j = len to 8 by -1; .ch. j, var_id = 1r ; end do;
smfa  94          temp = rn_offs(p);
smfa  95          if (len > 7) len = 7;
smfa  96          do j = len to 3 by -1;
smfa  97              .ch. j, var_id = charofdig(mod(temp, 10));
smfa  98              temp = temp / 10;
smfa  99          end do;
smfa 100          .s. 1, 2, var_id = 't$';
smfa 101          return;
smfa 102      end if;
smfa 103
smfa 104      ss1 = value_ tcomp(value(s_rnames), rn_indx(p));
smfa 105      assert ss_ofs(ss1) = 0;
smfa 106
smfa 107      temp = rn_offs(p);
smfa 108      word = ss_ptr(ss1) + icoffs(ss1, temp);
smfa 109      offs = icorg(ss1, temp);
smfa 110
smfa 111      temp = rn_len(p); if (0 < n & n < temp) temp = n;
smfa 112      do j = 1 to temp;
smfa 113          .ch. j, var_id = .f. offs, chsiz, heap(word);
smfa 114
smfa 115          if offs = chlst then
smfa 116              word = word + 1; offs = chorg;
smfa 117          else
smfa 118              offs = offs + chinc;
smfa 119          end if;
smfa 120      end do;
smfa 121
smfa 122      do j = temp+1 to n; .ch. j, var_id = 1r ; end do;
smfa 123
smfa 124      return;
smfa 125
      62
      63/error/   $ invalid name
      64
      65      var_id = '';
      66      return;
      67
      68      end fnct var_id;
       1 .=member checkptr
       2      subr checkptr(p, ht);
       3
       4$ this routine checks that the 'stdptr' field of heap(p)
       5$ contains a valid pointer. by this we mean that it points
       6$ to the first word of a data block. we check pointers for
       7$ validity by making a linear scan of the heap, looking at
       8$ the first word of each block until we find the desired one.
       9
      10$ we only check pointers if garbage collector tracing has been
      11$ requested.
      12
      13
      14      size p(ps),   $ address of word containing pointer
      15           ht(ps);  $ desired block type
      16
      17      size p1(ps),  $ pointer for iteration over heap
      18           len(ps);    $ length of block
      19
      20      size blksz(ps);         $ function called
      21
      22
      23$ return if we are not tracing the garbage collector
      24 .-gt  return;
      25 .+gt  if (gtrace = no) return;
      26
      27
      28$ make sure we are pointing into the heap.
      29      if stdptr(p) > h then
      30          put, skip, column(7), '*** found pointer out of heap', skip;
      31          go to error;
      32      end if;
      33
      34$ search for proper block
      35      p1 = ca_org;
      36
      37      while p1 < stdptr(p);
      38          len = blksz(p1);
      39
      40          if len = 0 then
      41              put, skip, 'found zero length block at ': p1, i;
      42              call ltlfin(1, 1);
      43          end if;
      44
      45          p1 = p1 + len;
      46      end while;
      47
      48
      49
      50      if p1 ^= stdptr(p) then  $ points to middile of block
      51          put, skip, column(7),
      52               '*** found pointer to middle of block ***', skip;
      53
      54      elseif ht ^= 0 & ht ^= htype(p1) then
      55          put, skip, '*** found pointer to wrong block type ***', skip;
      56
      57      else
      58          return;
      59      end if;
      60
      61/error/    $ dump bad word
      62
      63      put, column(7), 'word containing pointer:', skip;
      64      put, column(7): p, i, column(30):
      65           heap(p), bl(3), skip;
      66
      67      put, column(7), 'word pointed to', skip;
      68      put, column(7): stdptr(p), i, column(30):
      69           heap(stdptr(p)), bl(3), skip;
      70
      71
      72      end subr checkptr;
       1 .=member dummy
       2
       3$ this section of the library contains dummy routines to satisfy
       4$ missing externals.
       5
       6      +*  dummy(rout, msg) =  $ create dummy entry
       7
       8          subr rout;
       9
      10          call err_proc('calling dummy external ' .cc. msg, yes);
      11
      12          end subr rout;
      13          **
      14
      15
      16      dummy(shiftl, 'shiftl');
      17      dummy(shiftr, 'shiftr');
      18      dummy(sofb, 'sofb');
      19      dummy(real_over,  'real_over');
      20      dummy(real_under, 'real_under');
      21
      22
      23      macdrop(dummy)
      24
      25
      26 ..part4
       1 .=member putfreq
       2
       3 .+part1.
       4 .+st.
       5
       6
       7      subr put_freq;
       8
       9$ this routine finds the number of times each q2 opcode was
      10$ executed and prints it out.
      11
      12
      13      size p(ps),      $ pointer to code block
      14           tup(ps),    $ pointer to tuple
      15           i(ps),      $ loop index
      16           j(ps),      $ loop index
      17           op(ps),     $ opcode
      18           tab(ps),    $ tab position
      19           str(.sds.8),$ name of opcode
      20           freq(ps);   $ frequency
      21
      22      size blksz(ps),         $ functions called
      23           nulltup(hs);
      24
      25
      26$ there are two arrays, opname1 and opname2 which send q2
      27$ opcodes into their names. these arrays are contained in the
      28$ namesets opname1ns and opname2ns, and are initialized in the
      29$ routines opnam1 and opnam2. access the namesets and call
      30$ the initialization routines.
      31
      32      access nsopn1, nsopn2;
      33
      34      call opnam1;
      35      call opnam2;
      36
      37$ we begin by allocating a null tuple which maps q2 opcodes into
      38$ frequencies.
      39      tup = value_ nulltup(f_ituple, q2_maximum);
      40
      41$ next we iterate over all the code blocks, determining the frequency
      42$ of each opcode.
      43
      44      p = 1;
      45
      46      while p < h_org;
      47
      48          if (htype(p) = h_code) call add_freq(p, tup);
      49          p = p + blksz(p);
      50
      51      end while;
      52
      53$ next print out frequencies in 6 columns.
      54
      55      put, page, column(50), 'instruction frequencies', skip(2);
      56
      57      do i = 1 to q2_maximum/6;
      58          tab = 5;
      59
      60          do j = 1 to 6;
      61
      62              op = (i-1) * 6 + j;
      63
      64              if op <= q2_maximum then
      65                  if op < q2_asn then
      66                      str = opname1(op);
      67                  else
      68                      str = opname2(op);
      69                  end if;
      70
      71                  freq = tcomp(tup, op);
      72
      73                  put, column(tab): str, a, column(tab+10);
      74
      75                  if freq = om_int then
      76                      put: 1r*, r(1);
      77                  else
      78                      put: freq, i;
      79                  end if;
      80              end if;
      81
      82              tab = tab + 20;
      83          end do;
      84
      85          put, skip;
      86      end do;
      87
      88      return;
      89
      90      end subr put_freq;
       1 .=member addfreq
       2      subr add_freq(p, tup);
       3
       4$ scan a code block 'p' and determine the number of times each opcode
       5$ is executed. add the information to the tuple 'tup'.
       6
       7      size p(ps),     $ pointer to code block
       8           tup(ps);   $ pointer to tuple
       9
      10      size p1(ps),    $ pointer to instruction
      11           op(ps),    $ its opcode
      12           stmt(ps),  $ current statement number
      13           freq(ps);  $ number of times it was executed
      14
      15      access nsopn1, nsopn2;
      16
      17      p1 = p + hl_code;
      18
      19      while p1 < p + codenw(p);
      20          op = codeop(p1);
      21
      22          if op = q2_stmt then
      23              stmt = codea3(p1);
      24              freq = stat_tot(stmt, st_count);
      25          end if;
      26
      27          tcomp(tup, op) = tcomp(tup, op) + freq;
      28          p1             = p1 + inst_nw;
      29      end while;
      30
      31      end subr add_freq;
      32
      33 ..st
      34
      35 ..part1

« 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: