Personal tools
You are here: Home Projects SETL LITTLE Source code LIB: Run-time library for the LITTLE system (compile time and run time).
Document Actions

LIB: Run-time library for the LITTLE system (compile time and run time).

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

LIB: Run-time library for the LITTLE system (compile time and run time).

       1 .=member intro
       2 $     !$&'()*+,-./0123456789:;<=>abcdefghijklmnopqrstuvwxyz^_
       3 $    the above line contains, in order of ascii codes, the 56
       4 $    characters of the little language, starting in column 7.
       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 $    this software is part of the little programming system.
      31 $             address queries and comments to
      32 $
      33 $                      little project
      34 $              department of computer science
      35 $                   new york university
      36 $        courant institute of mathematical sciences
      37 $                    251 mercer street
      38 $                   new york,  ny  10012
      39 $
      40 $    this is the run-time library for the little system, and
      41 $    is known as 'lib'.
      42 $
      43 $    the principal authors of the little compiler are
      44 $    robert abes, edith deak, richard kenner, david shields
      45 $    and aaron stein.
      46 $
      47 $
       1 .=member chars
       2 /*   little character set and ascii representation
       3
       4       !$&'()*+,-./0123456789:;<=>abcdefghijklmnopqrstuvwxyz^_
       5      the above line contains, in order of ascii codes, the 56
       6      characters of the little language, starting in column 7.
       7
       8      the little language requires 56 distinct characters.
       9      these include the 26 upper case letters, the 10 digits,
      10      and the following special characters:
      11
      12        blank
      13      = equal sign, assignment symbol
      14      + plus
      15      - minus
      16      * times, asterisk
      17      / divide, slash
      18      ( left parenthesis
      19      ) right parenthesis
      20      , comma
      21      . period, point
      22      ; semicolon
      23      : colon
      24      $ dollar sign, comment character
      25      ^ not
      26      & and
      27      ! or
      28      < less than
      29      > greater than
      30      ' apostrophe, string delimiter
      31      _ underline, break character
      32
      33      the following table gives the standard ascii encoding
      34      for the little character set.
      35
      36        little character    ascii  ascii  ascii    ascii character
      37                            (hex)  (oct)  (dec)
      38
      39        space                  20     40     32    space
      40      ! or                     21     41     33    exclamation mark
      41      $ dollar sign            24     44     36    dollar sign
      42      & and                    26     46     38    ampersand
      43      ' apostrophe             27     47     39    apostrophe
      44      ( left parenthesis       28     50     40    left parenthesis
      45      ) right parenthesis      29     51     41    right parenthesis
      46      * asterisk               2a     52     42    asterisk
      47      + plus                   2b     53     43    plus
      48      , comma                  2c     54     44    comma
      49      - minus                  2d     55     45    minus
      50      . period                 2e     56     46    period
      51      / slash                  2f     57     47    slant
      52      0 digit 0                30     60     48    digit 0
      53      1 digit 1                31     61     49    digit 1
      54      2 digit 2                32     62     50    digit 2
      55      3 digit 3                33     63     51    digit 3
      56      4 digit 4                34     64     52    digit 4
      57      5 digit 5                35     65     53    digit 5
      58      6 digit 6                36     66     54    digit 6
      59      7 digit 7                37     67     55    digit 7
      60      8 digit 8                38     70     56    digit 8
      61      9 digit 9                39     71     57    digit 9
      62      : colon                  3a     72     58    colon
      63      ; semicolon              3b     73     59    semicolon
      64      < less than              3c     74     60    less than
      65      = equals                 3d     75     61    equals
      66      > greater than           3e     76     62    greater than
      67      a letter a               41    101     65    letter a
      68      b letter b               42    102     66    letter b
      69      c letter c               43    103     67    letter c
      70      d letter d               44    104     68    letter d
      71      e letter e               45    105     69    letter e
      72      f letter f               46    106     70    letter f
      73      g letter g               47    107     71    letter g
      74      h letter h               48    110     72    letter h
      75      i letter i               49    111     73    letter i
      76      j letter j               4a    112     74    letter j
      77      k letter k               4b    113     75    letter k
      78      l letter l               4c    114     76    letter l
      79      m letter m               4d    115     77    letter m
      80      n letter n               4e    116     78    letter n
      81      o letter o               4f    117     79    letter o
      82      p letter p               50    120     80    letter p
      83      q letter q               51    121     81    letter q
      84      r letter r               52    122     82    letter r
      85      s letter s               53    123     83    letter s
      86      t letter t               54    124     84    letter t
      87      u letter u               55    125     85    letter u
      88      v letter v               56    126     86    letter v
      89      w letter w               57    127     87    letter w
      90      x letter x               58    130     88    letter x
      91      y letter y               59    131     89    letter y
      92      z letter z               5a    132     90    letter z
      93      ^ not                    5e    136     94    circumflex
      94      _ underline              5f    137     95    underline
      95
      96 */
      97
       1 .=member mods
       2 $ -- all corrections are to insert mod notice after -- mods.2 --
ldsd   1
ldsd   2 $    ldsd      d. shields          20-jun-83
ldsd   3 $
ldsd   4 $    1.  increase oscmax to 512 fo s32.
ldsd   5 $    2.  extend incio to permit tabs, not just blanks, to be used
ldsd   6 $        to delimit keywords for .=member, .=include, except that
ldsd   7 $        directive must start with blank.
ldsd   8 $    decks affected - macros, incio
ldsd   9
ldsc   1
ldsc   2 $    ldsc      d. shields          23-jul-82
ldsc   3 $
ldsc   4 $    for s37, allow longer program parameter strings and also change
ldsc   5 $    specification for print file from 'l=sysprint/sysout' to just
ldsc   6 $    'l=sysprint/'.
ldsc   7 $
ldsc   8 $    decks affected - macros, ltlini
ldsc   9
dso    1
dso    2 $    ldsb      d. shields          15-jan-82
dso    3 $
dso    4 $    revise ltlfin to put etim output on standard output not terminal.
dso    5 $    write etim output only if normal termination. writing the output
dso    6 $    to terminal was confusing, especially for unix.
dso    7 $    deck affected - ltlfin (resequenced).
dso    8
dsnc   1
dsnc   2 $    dsnc      d. shields          15-dec-81
dsnc   3 $
dsnc   4 $    make the default for 'termp=' be system dependent.
dsnc   5 $    deck affected - ltlini
dsnc   6
dsn    1
dsn    2 $    dsn       d. shields          09-dec-81
dsn    3 $
dsn    4 $    1.  support termp=>/> to indicate terminal prompt to be given
dsn    5 $        for interactive input.
dsn    6 $        termp=0 gives no prompting.
dsn    7 $        termp requires new sio procedure promsio(fn,rc,string) to
dsn    8 $        set prompt for file fn to string. provide dummy promsio if
dsn    9 $        this feature not to be supported on a particular implementatio
dsn   10 $    2.  extend plf1 parameter option so that parameter values
dsn   11 $        containing commas can be enclosed in parentheses.
dsn   12 $    decks affected - ltlini, beglio, makf, reados
dsn   13
utsa   1
utsa   2 $    utsa      d. shields          29-nov-81           level 81333
utsa   3 $
utsa   4 $    support s47: amdahl uts (universal timesharing system).
utsa   5 $    this implementation runs on s37 architecture using an operating
utsa   6 $    system very close to unix (v7), and uses the ascii character set.
utsa   7 $    note that new decks s47xtr1 and s47errs will need revision for uts
utsa   8
dsm    1
dsm    2 $    dsm       d. shields          04-nov-81
dsm    3 $
dsm    4 $    for systems other than s66, have etim write its output to
dsm    5 $    terminal file. also, limit use of remarkl within this library
dsm    6 $    to very serious errors such as 'unable to open listing file'.
dsm    7 $    remarkl is based on s66, and semantics elsewhere not always clear.
dsm    8 $    also, slightly adjust ltlini so all globals in single nameset,
dsm    9 $    hence no need to have nameset with created name ($tlini, etc.).
dsm   10 $    decks affected - ltlini, ltlced, incio, ltlfin.
dsm   11
dsl    1
dsl    2 $    dsl       d. shields          21-sep-81
dsl    3 $
dsl    4 $    report fatal error (1010) if unable to open inclusion file.
dsl    5 $    deck affected - incio
dsl    6
dsua   1
dsua   2 $    dsua      d. shields          27-jan-81
dsua   3 $
dsua   4 $    adjust iolbamax for s10.
dsua   5 $    deck affected - beglio
dsua   6
dsk    1
dsk    2 $    dsk       d. shields          27-oct-80
dsk    3 $
dsk    4 $    1.  fix case folding in conditional assembly processing.
dsk    5 $    2.  add program parameter 'termh' such that title line generated
dsk    6 $        by ltitlr echoed to terminal only if termh=1. make default
dsk    7 $        'termh=1/0', except for s32, where want 'termh=0/1'.
dsk    8 $        new contlpr entries permit reading and changing termh.
dsk    9 $            contlpr(28, arg)  sets arg to termh value
dsk   10 $            contlpr(29, arg)  sets termh value to arg
dsk   11 $    3.  permit specification of number of characters in standard
dsk   12 $        output file (unit 2).  new program parameter
dsk   13 $        pfcl=0/80 permits specification of characters per line in
dsk   14 $        standard output file (including carriage control column).
dsk   15 $        'pfcl=0' yields default line length.
dsk   16 $        alternate '80' chosen to assist output to terminal.
dsk   17 $        new contlpr entry permits finding line length
dsk   18 $            contlpr(30,arg)  sets arg to line length of standard
dsk   19 $                             output file
dsk   20 $    decks affected - macros, ltlini, lcp, incio, makf
dsk   21
plf    1
plf    2 $    plf       d. shields          10-oct-80
plf    3 $
plf    4 $    add conditional assembly options to permit varying
plf    5 $    program parameter list formats, as follows
plf    6 $     plf0  comma is separator (default)
plf    7 $     plf1  comma is separator, except when between brackets
plf    8 $           ([ or < at left, ] or > at right). this format
plf    9 $           used for s10, s11 and s32, to permit passing
plf   10 $           fully-qualified file names.
plf   11 $    deck affected - reados
plf   12
dsj    1
dsj    2 $    dsj       d. shields          24-sep-80
dsj    3 $
dsj    4 $    add procedure -ltlced- (c-heck e-xpiration d-ate) to check
dsj    5 $    expiration date. expiration causes abnormal termination with
dsj    6 $    code 1009. execution within a month of expiration causes
dsj    7 $    generation of warning message. expiration only checked if
dsj    8 $    -expire- option in ltlgen used when compiling program.
dsj    9 $    deck affected - ltlced (new).
dsj   10
dsi    1
dsi    2 $    dsi       d. shields          30-jul-80
dsi    3 $              r. kenner
dsi    4 $
dsi    5 $    1.  fix problem (fr143) in multi-word extraction.
dsi    6 $    2.  correct spelling error in message in prhd.
dsi    7 $    3.  accept mixed case input in ilst (fixing fr137), iget
dsi    8 $        and vnum.
dsi    9 $    4.  fix macro definition for addrl for s37.
dsi   10 $    5.  support up to 20 files for s37.
dsi   11 $    6.  make page limit infinite for s37.
dsi   12 $    7.  change default for term= to 'term=systerm/' for s37.
dsi   13 $
dsi   14 $    * * *  new sio procedures - eretsio, ecodsio * * *
dsi   15 $
dsi   16 $    add eretsio(fn, rc, lev) to permit recovery from sio errors.
dsi   17 $    lev is  0  for no return if sio error (prior practice)
dsi   18 $            1  for terse return
dsi   19 $            2  for verbose return (issue error messages, etc.)
dsi   20 $    the setting persits across file closes. rc is set zero unless
dsi   21 $    fn is not a valid file number.
dsi   22 $
dsi   23 $    add ecodsio(fn, rc, src) to report system error code.
dsi   24 $    after a call to an sio procedure, ecodsio may be called.
dsi   25 $    rc is set to the value returned in the last sio call, and,
dsi   26 $    if an error has occurred, src is set to a system-dependent
dsi   27 $    value describing which error occurred.
dsi   28 $
dsi   29 $    the standard input and output files are opened with eretsio level
dsi   30 $    1 (terse return) and 2 (verbose return) respectively.
dsi   31 $
dsi   32 $    decks affected - macros, eexmw, prhd, ilst, iget, vnum, termio,
dsi   33 $        ltlini, makf.
dsi   34
dsh    1
dsh    2 $    dsh       d. shields          21-jul-80
dsh    3 $
dsh    4 $    1.  force load of blds if defenv_ss not set.
dsh    5 $    2.  for s32 vms, have getipp and getspp fold arguments.
dsh    6 $    decks affected - ltlini, getipp, getspp.
dsh    7
dsg    1
dsg    2 $    dsg       d. shields          11-jul-80
dsg    3 $
dsg    4 $    fix error (fr138) that caused extra blank line at end of
dsg    5 $    standard output file.
dsg    6 $    deck affected - rlse.
dsg    7
dsf    1
dsf    2 $    dsf       d. shields          10-jul-80
dsf    3 $    1.  add conditional symbol -unix- for the unix operating system.
dsf    4 $        use iset=unix to obtain unix variant.
dsf    5 $        delete all special env code for initial unix checkout.
dsf    6 $    2.  provide up to 20 files for s32.
dsf    7 $    3.  improve ltlfin, especially for s32.
dsf    8 $    4.  watch for possible sio error on file open. if cannot
dsf    9 $        open standard output (unit 2), issue error message using
dsj   11 $        -remarkl- and terminate with code 1007.
dsf   11 $    decks affected - macros, ltlfin, beglio, ltllio, makf.
dsf   12
dse    1
dse    2 $    dse       d. shields          21-apr-80
dse    3 $
dse    4 $    1.  allow up to 16 files for s32 and s37.
dse    5 $    2.  increase line buffer array for s32 and s37.
dse    6 $    3.  add option extime_off to permit support of timing feature,
dse    7 $        but not have times given by default.
dse    8 $    4.  fix error (fr132) that caused null lines to not be written.
dse    9 $    decks affected - macros, ltlini, beglio, flsh.
dse   10
dsd    1
dsd    2 $    dsd     d. shields              21-nov-79
dsd    3 $
dsd    4 $    support mixed case in specifying .=include and .=member
dsd    5 $    directives and also for member names.
dsd    6 $    deck affected - incio
dsd    7
dsc    1
dsc    2 $    dsc     d. shields              19-nov-79
dsc    3 $
dsc    4 $    1.  change default site name to 'nyu'. also adjust ltitlr
dsc    5 $        to work with names of differing lengths.
dsc    6 $    2.  have ltlini process 'term=' terminal option.  this avoids user
dsc    7 $        programs having to open terminal file. this change compatible
dsc    8 $        with existing use of opnterm.
dsc    9 $    3.  change page limit default to 'pfpl=100/0' so that
dsc   10 $        'pfpl' alone suppresses page limit check.
dsc   11 $    4.  do some initialization in opninc using data statements
dsc   12 $        instead of code.
dsc   13 $    5.  fix bug (fr2.3.124) in detecting conversion errors due
dsc   14 $        to misplaced test in vnum.
dsc   15 $    6.  add code for s10 to ctlc, ctuc.
dsc   16 $    7.  convert sstab in blds for s10 from sixbit to 9 bit.
dsc   17 $    8.  add parameter 'ilib=' to permit explicit naming of inclusion
dsc   18 $        text library.  null value selects default library name.
dsc   19 $    9.  if extime enabled to permit timing execution, support
dsc   20 $        program parameter 'etim=1/0' so that time not reported
dsc   21 $        if etim=0.
dsc   22 $    10. add procedure getapp(s, sl) which returns in string s of max.
dsc   23 $        length sl the full parameter string that invoked the program.
dsc   24 $        the maximum length of this string is getapp_len, which has
dsc   25 $        default length of 128 (240 for s32).
dsc   26 $    decks affected - ltlini, ltitlr, opnterm, incio, ltlfin, blds,
dsc   27 $        ctlc, ctuc, getapp (new).
dsc   28
dsb    1
dsb    2 $    dsb       d. shields          10-sep-79
dsb    3 $
dsb    4 $    1.  for s32, support parameter strings up to 300 characters, and
dsb    5 $        individual string parameters up to 64 characters.
dsb    6 $    2.  ignore non-digits in integer parameter strings to avoid
dsb    7 $        generating spurious values during integer conversion.
dsb    8 $    3.  for little i/o, recognize only error levels 1 and 2.
dsb    9 $        level 1 error indicates conversion/truncation error, level 2
dsb   10 $        indicates bad parameters or error on attempting operation.
dsb   11 $    4.  detect sio failure when opening, closing or rewinding file.
dsb   12 $    5.  permit io procedure pcsa to be defined in environment.
dsb   13 $    6.  correct confusion in conditional assembly of ltlterm.
dsb   14 $    decks affected - macros, getipp, getspp, reados, makf, rlse,
dsb   15 $        rwnd, pfin, istr, uinp, uout, ioer, ltlterm.
dsb   16
ldsa   1
ldsa   2 $    ldsa      d. shields          02-aug-79
ldsa   3 $
ldsa   4 $    1.  revise text inclusion routines to accept 'upd' argument to
ldsa   5 $        permit direct reading of little source from upd library files
ldsa   6 $        which have sequence information in first eight columns.
ldsa   7 $    2.  revise s10 configuration parameters to reflect use of
ldsa   8 $        9-bit ascii.
ldsa   9 $    3.  add string search functions as follows.
ldsa  10 $        anyc, anys, blds, brkc, brks, ctlc, ctuc, nayc, nays, rbrc
ldsa  11 $        rbrs, rpld, rple, rspc, rsps, spnc, spns, stlc, stuc
ldsa  12 $    decks affected - incio, new decks for anyc...stuc
ldsa  13
dsz    1
dsz    2 $    dsz       d. shields          05 jun 79
dsz    3 $
dsz    4 $    add special entry for subn in monitor package to permit setl
dsz    5 $    system to reset procedure table pointer.
dsz    6 $    deck affected - subn.
dsz    7
dsy    1
dsy    2 $    dsy       d. shields          11 apr 79
dsy    3 $
dsy    4 $    fix error (fr2.3.109) that had line pointer wrongly initialized
dsy    5 $    for access get.
dsy    6 $    deck affected - makf.
dsy    7
dsx    1
dsx    2 $    dsx       d. shields          01 feb 79
dsx    3 $
dsx    4 $    1.  add check for overflow in floating input (fr2.3.81).
dsx    5 $    2.  correct typos in correction dsw.
dsx    6 $    3.  add deck 'bneqmw' to provide multi word not-equal
dsx    7 $        needed by some asm's.
dsx    8 $    4.  fix getfmt macro to see if operation done (fr2.3.90).
dsx    9 $    5.  fix monitor package to have namesets in right place
dsx   10 $        (fr2.3.91) and have name length correct (fr2.3.92).
dsx   11 $    decks affected - lhdr, setx, subn, beglio, bneqmw.
dsx   12
dsw    1
dsw    2 $    dsw       d. shields          30 jan 79
dsw    3 $    1.  correct sizing error in monitor routine setx.  this fixes
dsw    4 $        fr2.3.76 and requires mod -dss- in gen be applied also.
dsw    5 $    2.  drop support for s16.
dsw    6 $    3.  add fields for s40 (prime 400).
dsw    7 $    decks affected - macros, beglio, setx.
dsw    8
vax    1
vax    2 $    vax       d. shields          21 nov  78          level 78325
vax    3 $              r. kenner
vax    4 $
vax    5 $    add configuration values for s32: dec vax-11/780.
vax    6 $    decks affected - macros, ltlini, ltlregl, begmon, beglio.
vax    7
dsv    1
dsv    2 $    dsv       d. shields          25 sep 78
dsv    3 $
dsv    4 $    1.  add code for resident s10 system.
dsv    5 $    2.  redo some standard macros to assume standard values,
dsv    6 $        and then add exceptions for particular implementations.
dsv    7 $    3.  fix reported bug in ltlxtr for s66.
dsv    8 $    decks affected - macros, beglio, ltlxtr.
dsv    9
dsu    1
dsu    2 $    dsu       d. shields          20 jun 78
dsu    3 $
dsu    4 $    1.  adjust dimension of iolb for s11.
dsu    5 $    2.  fix bug in lstime so argument initialized.
dsu    6 $    3.  fix size error in vcsmw.
dsu    7 $    4.  fix error in putf.
dsu    8 $    5.  add 'dmp=0/1' option for s66, to permit full memory
dsu    9 $        dump if system forces termination.
dsu   10 $    decks affected - ltlini, lstime, putf, beglio, vcsmw.
dsu   11
dst    1
dst    2 $    dst       d. shields          06 jun 78
dst    3 $
dst    4 $    1.  fix grouping problem in ofmi.
dst    5 $    2.  add code to ltlregl for s10.
dst    6 $    3.  change fatrasz for s10.
dst    7 $    decks affected - ltlregl (resequenced), beglio, ofmi.
dst    8
       3
       4 $    chars     d. shields          30 may 78           level 78150
       5 $
       6 $    include deck chars to describe character set to assist in
       7 $    correct translation of source text for new machines.
       8 $    correct error in use of cdc character set so that apostrophe
       9 $    represented by cdc display code 3b'70' (up arrow).
      10 $    decks affected - all (source resequenced).
      11
      12
      13 $    dss     d. shields         01 mar 78
      14 $            r. kenner
      15 $
      16 $    1.  fix traceback listing for s37.
      17 $    2.  fix error in multi-word not (last word was not left filled).
      18 $    3.  keep track of line number of formatted files.  on error
      19 $        list line number and recent line.  line number is number
      20 $        of sio operations done since file last positioned at start.
      21 $    4.  assign abnormal termination code 1008 for attempt to use
      22 $        function not defined/supported by an implementation.
      23 $    5.  add conditional assembly option  fp  to select support
      24 $        of floating point (real) operations.
      25 $        modify ifme, ofme and ofmf to recognize fp, and report
      26 $        error 1008 if called and floating point not supported.
      27 $    decks affected - ltlxtr, ioer, notmw, (misc.) io
      28
      29
      30 $    rgb       r. gezelter         25 jan 78
      31 $
      32 $    fix errors in mod rga.
      33 $    decks affected - macros, ltlregl, errmw.
      34
      35
      36 $    rga       r. gezelter         16 jan 78
      37 $
      38 $    fix conditional text for s11.
      39 $    decks affected - macros, ltlini, gobyerm, ltlregl, ltlterm.
      40
      41
      42 $    dsr       d. shields          18 jan 78
      43 $
      44 $    provide standard for handling previously 'undefined' array
      45 $    slices as follows, letting 'ara(lo) to ara(hi)' be model:
      46 $
      47 $    if  lo<=1, there is an error which should be reported.
      48 $    if  hi>=lo, a slice is to be transmitted as before.
      49 $    if  hi<(lo-1), there is an error which should be reported.
      50 $    if  hi=(lo-1), the slice is said to be 'null', and
      51 $        no data is to be transmitted.
      52 $
      53 $    the null slice is consistent with zero-width fields and
      54 $    zero-trip do loops, and permits such constructs as
      55 $        write f, ptr, ara(1) to ara(ptr);
      56 $    where ptr has value zero.
      57 $
      58 $    the above changes are reflected by making the word count
      59 $    parameter to uinp and uout be signed.   word count of
      60 $    zero is to result for null slice, and a negative word
      61 $    count indicates an invalid slice, resulting from lo<=1
      62 $    or hi<(lo-1).
      63 $    add error message to ioer for invalid array slice.
      64 $    decks affected - uinp, uout, ioer.
      65
      66
      67 $    dsq       d. shields          05 jan 78
      68 $
      69 $    1.  fix reported bug in support of -column- and
      70 $        -x(negative)- control formats by adding field -lbmax-
      71 $        to record true length of coded line.
      72 $    2.  slightly improve efficiency for s37 by redefining
      73 $        some file attribute fields as byte fields.
      74 $    decks affected - beglio, lpin, flsh, putf, gcfp.
      75
      76
      77 $    rke       r. kenner           02 jan 78
      78 $
      79 $    1.  fix errors in conditional text for s37 and selection
      80 $        of which routines should be compiled for various machines.
      81 $    2.  have -stitlr- clear title before it sets new one.
      82 $    3.  add third parameter to -rewisio- calls.
      83 $    4.  correct formatting problem in -ltlregl- for s37.
      84 $    5.  add -prs3-, -prs4-, and -prs5- to call -prst- with fewer
      85 $        parameters.
      86 $    6.  fix bug in -trfl- which causes labels not to be printed
      87 $        in flow trace and improve format of labels that get printed.
      88 $    7.  add missing 'access' statements in the multi-word routines.
      89 $    8.  add a -ltlterm- for the s37.
      90 $    9.  add new -ltlxtr- and some error routines for s37.
      91 $    decks affected - macros, lcp, incio, ltlregl, begmon, trfl,
      92 $                     prfl, deci, ltlterm, ltlxtr1, ltlfin,
      93 $                     s37xtr1 (new), s37errs (new)
      94
      95
      96 $    dsp       d. shields          08 nov 77
      97 $
      98 $    revise .e. procedures to handle zero length extracts correctly.
      99 $    decks affected - easmw, eexmw.
     100
     101
     102 $    dso       d. shields          31 oct 77
     103 $              r. kenner
     104 $
     105 $    1.  add conditional text for s10 (dec 10).
     106 $    2.  clean up program initialization (cf ltlini).
     107 $    3.  clean up makf, in particular to permit sio to return
     108 $        line size.
     109 $    4.  clean up lcp, and do more argument checking in contlpr.
     110 $    5.  clean up monitor package, recognize program procedure.
     111 $    6.  assign an encoding for abnormal termination codes passed
     112 $        to ltlfin, for use on s37.
     113 $    decks affected - most (source has been resequenced).
     114
     115
     116 $    dsn       d. shields          18 oct 77
     117 $
     118 $    make several fixes and changes to io, as follows.
     119 $    1.  do not permit read past end without filestat(,end) check.
     120 $    2.  improve error handling.
     121 $    3.  do conversion using negative arithmetic to avoid problems
     122 $        on twos complement machines.
     123 $    4.  simplify makf by having gen do some tests that can be done
     124 $        at compile time.
     125 $    5.  do not require column for sign position in integer output.
     126 $    6.  on s66, no longer attempt to convert integers of more than
     127 $        48 bits (they can only be added and subtracted, anyway.)
     128      $   decks affected - almost all from beglio thru endlio, lpin (new
     129
     130
     131 $    rkd       r. kenner           31 may 77
     132 $
     133 $    detected bug - grouping is done before field is blank filled.
     134 $    this causes unexpected results.
     135 $    fix - move call to -ogrp- in -pfin- to after the filling code.
     136 $    deck affected - pfin
     137
     138
     139 $    rkc       r. kenner           27 may 77.
     140 $
     141 $    1.  correct some macros for s16.
     142 $    2.  fix slighly conservative test in getipp.
     143 $    3.  change data statements in ltllio for ions to executable
     144 $        initialization to allow for space saving on s16.
     145 $    decks affected - macros, getipp, ltllio.
     146
     147
     148 $    rkb       r. kenner           26 may 77.
     149 $
     150 $    correctly report an error in makf using ioer instead of lcp,
     151 $    as s16 does not have lcp.
     152 $    decks affected - makf, ioer.
     153
     154
     155 $    dsm       d. shields          24 may 77.
     156 $
     157 $    reported bug - 'writing' flag not reset for reading.
     158 $    cause - an elseif in vali should be else.
     159 $    deck affected - vali.
     160
     161
     162 $    dsl       d. shields          13 may 77
     163 $
     164 $    1.  make -ignore- level of string access files one, so conversion
     165 $        and truncation errors on such files not fatal by default.
     166 $    2.  add procedure 7nsigl$io(f,ilev) to set ignore level of file f
     167 $        to ilev, to permit user to override default settings.
     168 $    decks affected - makf, ioer, sigl(new).
     169
     170
     171 $    dsk       d. shields          06 may 77
     172 $
     173 $    1.  reported bug - on s16, format 'b(7,3)' gives occasional
     174 $        erroneous high order bits.
     175 $        cause - ofmb was not resetting for high order byte.
     176 $    2.  reported bug - -a- input format not working on string file.
     177 $        cause - s66 special case did not check for string file.
     178 $    3.  reported bug - list input mode bombing on end of file.
     179 $    4.  correct code for -b- conversion in case byte width three and
     180 $        word size not multiple of three.
     181 $        cause - debug trace code inadvertently left in.
     182 $    decks affected - ofmb, ifma, ifmb, ilst, pcsa.
     183
     184
     185 $    dsj       d. shields          21 apr 77
     186 $
     187 $    install revised semantics for string access files.
     188 $    decks affected - makf, rwnd, istr, ostr, gcfp, pcsa(new), ioer,
     189 $        grem (deleted), prem (deleted).
     190
     191
     192 $    dsi       d. shields          14 apr 77.
     193 $
     194 $    1.  make 'line limit exceeded' force abnormal termination.
     195 $    2.  support 'erexit' option, conditioned by name erexit, if
     196 $        operating system permits processing after adress exception,
     197 $        time limit, etc.  this involves two procedures.  procedure
     198 $        7nerxi$si is called by ltlini to initialize for recovery.
     199 $        the recovery is nominally named '7nerxp$si' but is not
     200 $        directly referenced.  erxp$si should call ltlfin(1,0) to
     201 $        indicate abnormal termination.
     202 $    3.  ltlfin now calls procedure usratp (user a-bnormal
     203 $        t-ermination p-rocedure) in case of abnormal
     204 $        termination.  usratp should not attempt to continue
     205 $        execution.
     206 $    decks affected - linelr, ltlini, ltlfin.
     207
     208
     209 $    dsh       d. shields          14 mar 77.
     210 $
     211 $    correct some problems in ofmf in handling of small quantities.
     212 $    deck affected - ofmf.
     213
     214 $    sys16    t. stuart   5 april 1977
     215
     216 $    1. redefine numerous constants for the s16 implementation
     217 $    2. correct an extractor macro in deck begmon
     218 $    3. add deck io16 which contains system 16 replacements for  some
     219 $    i/o procedures
     220
     221
     222
     223 $    rka       r. kenner           6 april 1977
     224 $
     225 $    correct two bugs in lio:
     226 $    1.  when error 12 (cannot allocate line buffer) occurs, the access
     227 $        value for the file must be cleared.  otherwise the program
     228 $        will not terminate cleanly because -ltllio- will attempt to
     229 $        disconnect a file which was not connected.
     230 $    2.  there is a bug in -rlse- where the line buffers are moved
     231 $        down.  this causes spurious error 12's.
     232 $    decks affected - makf, rlse.
     233
     234
     235 $    dsg       d. shields          14 mar 77.
     236 $
     237 $    reset -endseenv- before call to getw in istr so can read past
     238 $    end marks in file.
     239 $    deck affected - istr.
     240
     241
     242 $    dsf       d. shields          25 february 1977.
     243 $
     244 $    1.  fix size error of -printsw- in -flsh-.
     245 $    2.  correct retrieval of io parameters in some put procedures
     246 $        which inadvertently accessed input parameter list.
     247 $    3.  install width parameters for -bl-, -el-, -fl- and -rl-
     248 $        formats.
     249 $    decks affected - flsh, ofmb, ofme, ofmf, ofmi, ofmr.
     250
     251
     252 $    dse       d. shields          31 january 1977.
     253 $
     254 $    1.  correct error in computation of point position by vnum.
     255 $    2.  initialize variable deci_nsd in ltllio.
     256 $    decks affected - ltllio, vnum.
     257
     258
     259 $    dsd       d.  shields         27 january 77.
     260 $
     261 $    1.  insert missing assignment of -gw- in ofmi.
     262 $    2.  use .s. instead of .ch. in some -lcp- string operations.
     263
     264
     265 $    dsc      d. shields             26 january 77.
     266 $
     267 $    1.  make linesize 90 for std. input file for s66.
     268 $    2.  correct misplaced test in gcfp.
     269 $    3.  correct error processing in makf to use ioer.
     270 $    4.  move misplaced declaration in ifma.
     271 $    decks affected - gcfp, ltllio, makf, ioer, ifma.
     272
     273
     274 $    dsb       d.shields           24 january 77.
     275 $
     276 $    1.  reported bug - coded line not flushed on rewind.
     277 $        fix - include code to write last line in rwnd.
     278 $    deck affected - rwnd.
     279
     280
     281 $    dsa       d. shields          20 jan 77
     282 $
     283 $    1.  clear line buffer after -put-, so -column- format works
     284 $        correctly.
     285 $    2.  install code in ltlfin to time execution.
     286 $    3.  drop procedure -exitl- (ltlfin is to be used).
     287 $    decks affected - macros, ltllib, ltlfin, exitl(dropped),
     288 $                flsh, gcfp.
     289
       1 .=member begltl
       2 $  begin little portion of ltllib
       1 .=member macros
       2
dsi   35
dsi   36      $   select mc if lower-case characters available.
dsi   37
dsi   38 .+set mc  $ assume mixed-case characters available.
dsi   39
dsi   40 .+s66.
dsi   41 .-set mc  $ upper case only on s66
dsi   42 ..s66
dsi   43
plf   13 .+set plf0  $ assume commas in parm lists always separators
dsi   44 $    if mixed-case available, default primary case is upper.
dsi   45 $    obtain lower primary case by defining mcl.
dsi   46
       3      $   indicate procedures implemented by environment.
       4
       5 $    since multiword arithmetic temporarily dropped,
       6 $    indicate that defined in environment so little
       7      $   multiword arithmetic procedueres not compiled.
       8 .+set defenv_addmw
       9 .+set defenv_submw
      10 .+set defenv_mulmw
      11 .+set defenv_divmw
      12 .+s11.
      13 .+set defenv_readsos
plf   14 .-set plf0
plf   15 .+set plf1
      14 ..s11
      15
dsv   10 .+s10.
dsv   11 .+set  defenv_linepack
dsv   12      +*  linepack(pa, ua, nc) =
dsv   13          call 6npack$l(pa, 1, ua, 1, nc); **
dsv   14 .+set  defenv_readsos
plf   16 .-set plf0
plf   17 .+set plf1
dsv   15 ..s10
utsb   1
utsb   2 .+s32.
utsb   3 .+set s32v  $ assume vms.
utsb   4 ..s32
utsb   5
utsb   6 .+s32u.
utsb   7 .+s32.
utsb   8 .-set s32v  $ do not want vms.
utsb   9 .+set s32u  $ want unix os.
utsb  10 ..s32
utsb  11 .+set mcl   $ want primary case to be lower.
utsb  12 ..s32u
vax    8 .+s32.
plf   18 .-set plf0
plf   19 .+set plf1
vax    9 .+set defenv_readsos
vaxa   1 .+set defenv_linepak
utsb  13 .+s32v.
vaxa   2      +*  linepak(pa, ua, nc) =  $ use interface procedure.
vaxa   3          7npack$li(pa, 1, ua, 1, nc) **
utsb  14 ..s32v
vaxa   4 .+set defenv_ss  $ string search procedures defined in environment
vaxb   1 .+set defenv_casmw
vaxb   2 .+set defenv_catmw
vaxb   3 .+set defenv_cexmw
vaxb   4 .+set defenv_ceqmw
vaxb   5 .+set defenv_cinmw
vaxb   6 .+set defenv_vcsmw
vax   10 ..s32
      16 .+s37.
mtsa   1 .+set s37cms                 $ assume cms operating system
mtsa   2
mtsa   3 .+s37mts                     $ if mts operating system
mtsa   4 .-set s37cms                 $     reset cms flag
mtsa   5 .+set s37mts                 $     set mts flag (redundant)
mtsa   6 ..s37mts
mtsa   7
      17 .+set defenv_linepak
      18      +*  linepak(pa, ua, nc) =  $ use interface procedure.
      19          7npack$li(pa, 1, ua, 1, nc) **
      20 .+set defenv_readsos
      21 .+set defenv_lstime  $ lstime defined by environment.
      22 .+set defenv_fbtmw
      23 .+set defenv_nbtmw
      24 .+set defenv_casmw
      25 .+set defenv_catmw
      26 .+set defenv_cexmw
      27 .+set defenv_ceqmw
      28 .+set defenv_cinmw
      29 .+set defenv_vcsmw
      30 .+set defenv_ersmw
      31 ..s37
utsa   9
utsa  10 .+s47.
utsa  11 .-set defenv_linepak
utsa  12 .+set defenv_readsos
utsa  13 .-set defenv_lstime  $ lstime defined by environment.
utsa  14 .-set defenv_fbtmw
utsa  15 .-set defenv_nbtmw
utsa  16 .-set defenv_casmw
utsa  17 .-set defenv_catmw
utsa  18 .-set defenv_cexmw
utsa  19 .-set defenv_ceqmw
utsa  20 .-set defenv_cinmw
utsa  21 .-set defenv_vcsmw
utsa  22 .-set defenv_ersmw
utsa  23 ..s47
      32
      33 .+s66.
      34 .+set defenv_linepak
      35      +*  linepak(pa, ua, nc) =  $ use interface procedure.
      36          7npack$li(pa, 1, ua, 1, nc) **
      37 .+set defenv_lctime
      38 .+set defenv_lstime  $ lstime defined by environment.
ssa    1 .+set defenv_ss  $ string search procedures defined in environment
      39 .+set defenv_andmw
      40 .+set defenv_iormw
      41 .+set defenv_xormw
      42 .+set defenv_notmw
      43 .+set defenv_fbtmw
      44 .+set defenv_nbtmw
      45 .+set defenv_casmw
      46 .+set defenv_cexmw
      47 .+set defenv_catmw
      48 .+set defenv_ceqmw
      49 .+set defenv_cinmw
      50 .+set defenv_vcsmw
      51 .+set defenv_ersmw
      52 ..s66
      53
utsb  15 .+s32u.
dsf   16 $ disable defenv options for initial unix checkout.
dsf   17 .+set defenv_readsos
dsf   18 .-set defenv_linepak
dsf   19$     +*  linepak(pa, ua, nc) =  $ use interface procedure.
dsf   20$         7npack$li(pa, 1, ua, 1, nc) **
dsf   21 .-set defenv_ss  $ string search procedures defined in environment
dsf   22 .-set defenv_casmw
dsf   23 .-set defenv_catmw
dsf   24 .-set defenv_cexmw
dsf   25 .-set defenv_ceqmw
dsf   26 .-set defenv_cinmw
dsf   27 .-set defenv_vcsmw
utsb  16 ..s32u
dsf   29
      54
      55      $   end of environment-defined procedure list.
      56
      57      $   select those procedures which only exist in the environment
      58      $   and select which ones exists for each machine.
dsv   16 .+s10.
dsv   17 .+set txtl_env
dsv   18 .+set unpk_env
dsv   19 .+set pack_env
dsv   20 .+set spak_env
dsv   21 ..s10
vaxa   5 .+s32.
vaxa   6 .+set    txtl_env,unpk_env,pack_env,spak_env
vaxa   7 ..s32
      59 .+s66.
      60 .+set    txtl_env,unpk_env,pack_env,spak_env
      61 ..s66
      62 .+s37.
      63 .+set    txtl_env,unpk_env,pack_env,spak_env
      64 ..s37
utsa  24 .+s47.
utsa  25 .-set    txtl_env,unpk_env,pack_env,spak_env
utsa  26 ..s47
      65
utsb  17 .+s32u.
dsf   31 $ delete special env code for unix checkout.
dsf   32 .-set    txtl_env,unpk_env,pack_env,spak_env
utsb  18 ..s32u
dsh   17
utsa  27 .+s47.
utsa  28 .+set mcl  $ primary case lower
utsa  29 ..s47
utsa  30
dsi   48
dsi   49 .+mc.
dsi   50 .+mcl.   $ if mixed-case to be lower
dsi   51      +*  ctpc(x) = ctlc(x) **  $ primary case is lower.
dsi   52      +*  stpc(x) = stlc(x) **  $ primary case is lower.
dsi   53 .-mcl.
dsi   54      +*  ctpc(x) = ctuc(x) **  $ primary case is upper.
dsi   55      +*  stpc(x) = stuc(x) **  $ primary case is upper.
dsi   56 ..mcl
dsi   57 ..mc
dsi   58
      66 /*
      67      abnormal termination codes.
      68      the following codes are used as the second argument to
      69      -ltlfin- to indicate type of abnormal termination.
      70
      71      some implementations may report these codes to the user as
      72      and abend or completion code.
      73
      74      1001         line limit exceeded.
      75      1002         bad go to index.
      76      1003         inclusion depth too great or inclusion recursion.
      77      1004         bad name for cross-reference file.
      78      1005         array index out of range.
      79      1006         assertion failed.
      80      1007         unable to open standard print file.
      81      1008         request for undefined/unsupported function
dsj   12      1009         expiration date passed
dsl    7      1010         unable to open inclusion file.
      82      1101-1199    math library error n-1100.
      83      1201-1299    multiword error n-1200.
      84      1301-1399    little input/output error n-1300
      85      2000+        reserved for use by machine-dependant environment
      86 */
      87
      90      $   conditional assembly options.
      91
      92      $   select extime to have ltlfin display execution time.
dse   11 $    extime causes inclusion of code to support execution timing.
dse   12 $    the etim program parameter determines if timings listed.
dse   13 $    select extime_off to have times not listed by default.
vaxa   9 .+set extime
dse   14 .+set extime_off
      93 .+s66.
      94 .+set extime
exta   1 .-set extime_off
      95 ..s66
      96
      97      $   select wsm3 if word size is multiple of three.
dsv   22 .+s10.
dsv   23 .+set  wsm3
dsv   24 ..s10
      98 .+s66.
      99 .+set  wsm3
     100 ..s66
     101
     102      $   select erexit if error exit processing available.
     106 .+s66.
     107 .+set erexit
smp    1      $   select -smps66- to enable nos support of -smp- execution
smp    2      $   profile.
smp    3 .+set smps66
     108 ..s66
     109
     110      $   select inclseq to use sequencial model of inclusion.
     111      $   since all we have now is sequencial model, this is set.
     112 .+set  inclseq
     113
     114      +*  slen = .len. **   $ length field of sds
     115
     116      +*  sorg = .f. .sl.+1, .so., ** $ origin field of sds
     117
     118      +*  ldcs = (.sl.+.so.) **  $ combined length of sds origin, leng
     119
     120      +*  ws = .ws. ** $ number of bits in machine word
     121
     122      +*  ps = .ps. **  $ number of bits in machine pointer (address)
     123
     124      +*  cs = .cs. **  $ number of bits in character
     125
     126      +*  yes = 1 **
     127      +*  no  = 0 **
     128
     129      +*  cpw = (.ws./.cs.) ** $ characters per machine_word
     130
     131      +*  blankword =  $ word of blanks
ldsa  14 .+s10    4r            $ 9-bit ascii version
     133 .+s11    2r
vax   11 .+s32    4r
     135 .+s37    4r
utsa  31 .+s47    4r
dsw    9 .+s40    2r
     136 .+s66    10r
     137          **
     138
     139      +*  charofdig(d) =  $ maps digit to character code
     140          (d+1r0) $ if characters in order
     141          **
     142
     143      +*  digofchar(c) = $ maps decimal character onto value
     144          (c-1r0) $ if characters for digits in order
     145      **
     146
     147      +*  sds(n) = .sds. (n) **  $ size of n character string
     148
dsv   25      +*  letimesz = ws **  $ size of -letime- result.
dsv   26 .+s11    +*  letimesz = 32 **
     156
     157
dsv   27      +*  filenamelen = 20 **  $ default maximum file name length.
dsb   17 .+s32    +*  filenamelen = 64 **
utsa  32 .+s47    +*  filenamelen = 64 **
     165
dsv   28      +*  filenamelenblanks = 20q                       **
dsb   18 .+s32.
dsb   19      +* filenamelenblanks =
dsb   20 64q
dsb   21          **
dsb   22 ..s32
utsa  33 .+s47.
utsa  34      +*  filenamelenblanks =
utsa  35  64q
utsa  36      **
utsa  37 ..s47
     173
     174      $   spplen is string program parameter maximum length.
     175      +*  spplen = 20 **
dsb   23 .+s32 +*  spplen = 64 **
utsa  38 .+s47  +*  spplen = 64 **
     176 $    macros related to user option string processing
     177 $    see procedures reados and readsos.
     178
     179      +*  oscmax = 80 **  $ maximum length of option string
ldsd  10 .+s32  +*  oscmax = 512 **  $ accept long parameter strings for s32.
ldsc  10 .+s37  +*  oscmax = 300 **  $ accept long parameter strings for s37.
utsc   1 .+s47  +*  oscmax = 300 **  $ accept long param. strings.           uts
dsb   25      +*  ospmax = filenamelen **  $ maximum length of strings used for
dsc   29      $   getapp_len is maximum length of string returned by getapp.
dsc   30      $   this cannot exceed maximum length of sds.
dsc   31          +*  getapp_len = 128 **
dsc   32 .+s32    +*  getapp_len = 240 **
utsa  40 .+s47    +*  getapp_len = 240 **
dsc   33
     181          $ string parameter codes and values.
     183
     184
     185      +*  q3(a,b,c) = a b c**
     186      +*  macdef(text) = q3(+,*text*,*)**
     187      +*  macdrop(mname) = macdef(mname=)**
     188
dsv   29      +*  szmax = 2047 **  $ maximum item size.
     198
     199      +*  wordi(i,arg) = .f. 1+(i-1)*ws, ws, arg **
     200      +*  lcpns =  $ name of lcp nameset.
     201          6nlcp$ns
     202          **
     203
     204 $    the output functions to be used in generating print lines
dsw   10 .+s40.
dsw   11      $ change names on s40 to create 4 character unique names
     207      +* wordsr = wrdsr **  +* wordlfr = wrdfr **
     208      +* intlpr = intpr **  +* octlpr = octpr **
     209      +* readsos =rdsos **
dsw   12 ..s40
     211 $
     212      +*  endl = call endlr; **   $ end current line
     213      +*  textl(s) = call textlr(s); **   $ add string to current line
     214      +*  intl(i) = call intlr(i);**  $ add integer (5 cols) to line
     215      +*  intlp(i,c) = call intlpr(i,c);** $ add c column integer to li
     216      +*  octl(i) = call octlr(i); **  $ add octal value to line
     217      +*  octlp(v,c) = call octlpr(v,c);**$ output v in octal,
     218      +*  octlv(v) = call octlpr(v,((.fb.v-1)/3+1)); **
     219          $ output v as octal, leadnng zeros suppressed
     220      +*  hexlp(v, c) = call hexlpr(v, c); **  $ output in hex
     221      +*  wordl(i) = call wordlr(i);**  $ add word (00 ends) to line
     222      +*  wordlf(i) = call wordlfr(i);** $ add full word to line
     223      +*  charl(c) = call charlr(c); ** $ add chaacter to line
     224      +*  tintl(s,i) = call tintlr(s,i); ** $ output text and integer
     225      +*  getlpos(p) = call contlpr(1,p);** $ get currnt line position
     226      +*  setlpos(p) = call contlpr(2,p);** $ set current line position
     227      +*  skipl(p) = call contlpr(3,p); **  $
     228      +*  tabl(p) = call contlpr(4,p); **  $ tab to column -p-
     229
     230      $   pflen is the length of a print line, including the carriage
     231      $   control character.  the value of 133 is suggested as this is
     232      $   value for s37.
dsk   23      +*  pflenmax =
     234          133
     235          **
     236
dsv   30      $   print file parameter initial values.
dsv   31
dsv   32      +*  pfdefaultlinelimit = 'pfll=0/' **
dsv   33
dsc   34      +*  pfdefaultpagelimit = 'pfpl=100/0' **
vaxc   1 $    for s32, make page limit infinite by default.
vaxc   2 .+s32 +*  pfdefaultpagelimit = 'pfpl=0/0' **
dsi   59 $    for s37, make page limit infinite by default.
dsi   60 .+s37 +*  pfdefaultpagelimit = 'pfpl=0/0' **
utsa  41 .+s47 +*  pfdefaultpagelimit = 'pfpl=0/0' **
dsv   35
dsv   36      +*  pfdefaultlinesperpage = 'pflp=60/' **
dsv   37
dsv   38      $   sitename appears as part of standard title line.
dsc   35
dsc   36      +*  sitename = 'nyu' **
dsc   37      +*  sitenamelen = 3 **  $ length of sitename (cf. ltitlr)
     270
     271      +*  lstimelen = 30 **
     272
     273      $   memory access procedure names (use with caution).
     274      +*  memget = 7nmget$li **
     275      +*  memptr = 7nmptr$li **
     276      +*  memput = 7nmput$li **
     277
     338
     339      +*  wpc =   $ words per card
ldsa  15 .+s10    20  $ 80 columns (4*20)
     341 .+s11    40  $ 80 column  (2*40)
vax   12 .+s32    20  $ 80 columns (4*20)
     343 .+s37    20  $ 80 columns (4*20)
utsa  42 .+s47    20  $ 80 columns (4*20)
dsw   13 .+s40    40  $ 80 column  (2*40)
     344 .+s66    10  $ 90 columns (10*9)  90 for update compile files.
     345          **
dsv   41      $   mradix is default machine radix (assume octal).
dsv   42
dsv   43      +*  mradix = 3 **
vax   13 .+s32    +*  mradix = 4 **  $ use hexadecimal for s32
dsv   44 .+s37    +*  mradix = 4 **  $ use hexadecimal for s37
utsa  43 .+s47    +*  mradix = 4 **  $ use hexadecimal for s37
dsv   45
dsv   46      $   bwordl lists machine word in appropriate format.
dsv   47      $   bwordlen is number of characters for bwordl.
dsv   48      $   addrl lists machine address in appropriate format.
dsv   49      $   addrlen is length of addrl result.
dsv   50
dsv   51      +*  bwordl(w) = octl(w); **
vax   14 .+s32    +*  bwordl(w) = hexlp(w, 8); **  $ s32 is hex.
dsv   52 .+s37    +*  bwordl(w) = hexlp(w, 8); **  $ s37 is hex.
utsa  44 .+s47    +*  bwordl(w) = hexlp(w, 8); **  $ s37 is hex.
dsv   53
dsv   54      +*  bwordlen = (ws/3) **
vax   15 .+s32    +*  bwordlen = 8 **
dsv   55 .+s37    +*  bwordlen = 8 **
utsa  45 .+s47    +*  bwordlen = 8 **
dsv   56
dsv   57      +*  addrl(w) = octlp(w, 6); **
vax   16 .+s32  +*  addrl(w) = hexlp(w, 8); **
dsi   61 .+s37  +*  addrl(w) = hexlp(w, 6); **
utsa  46 .+s47  +*  addrl(w) = hexlp(w, 6); **
dsv   59
vax   17      +*  addrlen = ((ps + mradix - 1) / mradix) **
dsv   62
dsv   63      $   inclusion processing.
dsv   64      $   memnamelenmax is maximum length of member name.
dsv   65      $   inclevmax is maximum depth of inclusion.
dsv   66      $   inclibname is name of standard inclusion library.
dsv   67
dsv   68      +*  memnamelenmax = 20 **
dsv   69
dsv   70      +*  inclevmax = 6 **
     349
     350 .-set makfprfi  $ print file status in makf (debug).
     351
     352      $   set fp if floating arithmetic is supported, default is on.
     353 .+set  fp
     354 .+s11.
     355 .-set  fp
     356 ..s11
     357
     358      +* deciaralen = 40 **   $ length of integer conversion array.
     359      +* deci_lsd = 40 **
     360
     361 $   macros for -little- i/o procedures - mostly, fields of status words
     362
dsv   74      $   maxfiles is maximum number of simultaneously open files.
dsv   75
dsv   76      +*  maxfiles = 10 **
dsv   77 .+s11    +*  maxfiles = 15 **
dsf   36 .+s32    +*  maxfiles = 20 **
dsi   62 .+s37    +*  maxfiles = 20 **
utsa  47 .+s47    +*  maxfiles = 20 **
dse   17
dse   18 $    termfilenumber is unit number for terminal file. since this
dse   19 $    file possibly open on all runs, it is allocated as largest
dse   20 $    possible number.
dse   21 $    incfilenumber is unit number for text inclusion library.
dse   22 $    it is not always needed, and so is allocated in same way as
dse   23 $    term file. note that termfile and include file were added after
dse   24 $    standard input and output file numbers established. they are
dse   25 $    allocated 'at the end' to avoid conflicts with old programs.
dse   26
dse   27      +*  termfilenumber = maxfiles **
dse   28      +*  incfilenumber = (maxfiles-1) **  $ inclusion file number.
     370
     371      $   since two's complement machines have a negative value whose
     372      $   absolute value is one greater than the value of the largest
     373      $   positive integer, integer conversion is done using negative
     374      $   values.  maxnegint is the value of the smallest negative
     375      $   integer.
     376
     377      +*  maxnegint = $ value of smallest negative integer.
     378      $   give as bit constants to avoid conversion problems.
     379 .+s10    4b'8 0000 0000'
     380 .+s11    3b'100000'
vax   18 .+s32    4b'8000 0000'
     382 .+s37    4b'8000 0000'
utsa  48 .+s47    4b'8000 0000'
dsw   14 .+s40    4b'8000'
     383 .+s66    3b'7777 0000 0000 0000 0000'
     384          **
     385
     386
dsv   78      $   gotoem gives name of error proc for indexed go to error.
dsv   79      +*  gotoem = 7ngoto$em **
dsv   80 .+s11  +*  gotoem = 6ngoto$m **
goa    1 .+s10  +*  gotoem = 6ngoto$m **
     394
     395      $   codes used for accessv values.
     396      +*  access_get = 1 **
     397      +*  access_print = 2 **
     398      +*  access_put = 3 **
     399      +*  access_read = 4 **
     400      +*  access_string = 5 **
     401      +*  access_write = 6 **
     402      +*  access_release = 7 **
       1 .=member ltlini
       2      subr ltlini(c);  $ initiate little system.
       3      $   initialize little library.  c is zero if little alone,
       4      $   nonzero if running in presence of host.
       5      $   for now, assume little alone.
       6      size  c(ps);            $ case.
       7
       8 $
       9 $    all global variables used by the little library procedures
      10 $    not otherwise explicitly defined in their own nameset are
      11 $    to be defined here in nameset -lcpns-.
      12
dsm   12      nameset lcpns;
      13 .+extime size  timeon(letimesz);
dsc   38 .+extime size  etim(ps);    $ on if want execution time reported
      15      size  inputfilename(.sds. filenamelen);  $ input file name.
      16      size  printfilename(.sds. filenamelen);  $ print file name.
dsc   39      size  termfilename(.sds. filenamelen);  $ terminal file name.
dsc   40      size  inclibname(.sds. filenamelen);  $ include file name.
dsk   24      size  pfl(cs); dims pfl(pflenmax);  $ print file line.
      18      size  pfcol(ps);        $ print line column (of next character)
      19      data  pfcol = 2;
      20      size  pfline(ps);       $ print line number (last line completed)
      21      data  pfline = 0;
      22      size  pfpage(ps);       $ print file page number.
      23      size  pflinetotal(ps);  $ total lines written on print file.
      24      data  pflinetotal = 0;  $ no lines written at start
      25      size  pflinelimit(ps);  $ print file line limit.
      26      size  pfpagelimit(ps);  $ print file page limit.
      27      size  pfcarriage(1);    $ on to allow carriage control in col. 1.
      28      size  pflinesperpage(ps);  $ lines per print file page.
dsk   25      size  pftitle(.sds. pflenmax);  $ main print title.
dsk   26      size  pfstitle(.sds. pflenmax);  $ print file subtitle.
      31      size  pftitling(1);     $ on if titline print file.
      32      data  pftitling = no;
      33      size  pfpaging(1);      $ on if forming print file pages.
      34      data  pfpaging = no;
      35      size  pfpagefield(ps);  $ field in title for page number.
      36      size  pfdatefield(ps);  $ field in title for date.
      37      size  pftermflag(1);    $ on to write to terminal file
      38      data  pftermflag = no;  $ default is not to write to term file
      39      size  pflistflag(1);    $ on to write to listing file
      40      data  pflistflag = yes; $ default is to write to list file
      41      size  pftermopen(1);    $ on if terminal file open
      42      data  pftermopen = no;  $ terminal file is initially closed
      43      size  dblinelim(ps);    $ monitor line limit
      44      size  dblinect(ps); data  dblinect=1;  $ line counter
      45      size  dbstoplist(1); data  dbstoplist = no;  $ on to stop prin
      46      size  dblinenum(ps); data dblinenum = 0;  $ used to space lines
      47      data  pfl(1) = 1r ;     $ carriage control is initially blank
dsk   27      size  pflen(ps);  $ length of print line.
dsk   28      data  pflen = pflenmax;
dsk   29      size  termh(ps);  $ on for terminal header.
dsk   30      data  termh=yes;
dsn   14      size termprompt(.sds. filenamelen);
dsn   15      data termprompt = '>';
      48      end nameset;
      49
      50      call sysini(0);  $ perform necessary system initialization.
      51
      52 .+extime  call letime(timeon);  $ get starting time.
smp    4 .+smps66   call 7nsmpi$li;  $ to check for -smp- run.
      53      call ltlsio(0);
      54
dsc   41 .+extime.
dsc   42      $   etim=0 permits suppressing reporting elapsed time if
dsc   43      $   execution time being noted.
dse   29 .-extime_off   call getipp(etim, 'etim=1/0');  $ get option
dse   30 .+extime_off   call getipp(etim, 'etim=0/1');  $ get option
dsc   45 ..extime
dsc   46
      55      $   get names of standard input and print files.
      56
      57 .+s10.
      58      call getspp(inputfilename, 'i=*.ltl/');
      59      call getspp(printfilename, 'l=*.lst/');
dsc   47      call getspp(termfilename,  'term=tty:/');
dsc   48      call getspp(inclibname,    'ilib=syslib/');
      60 ..s10
      61 .+s11.
      62      call getspp(inputfilename, 'i=ti:/');
      63      call getspp(printfilename, 'l=ti:/');
dsc   49      call getspp(termfilename,  'term=ti:/');
dsc   50      call getspp(inclibname,    'ilib=syslib/');
      64 ..s11
utsb  19 .+s32u.
utsb  20      call getspp(inputfilename, 'i=stdin/');
utsb  21      call getspp(printfilename, 'l=stdout/');
utsb  22      call getspp(termfilename,  'term=stderr/');
dsc   52      call getspp(inclibname,    'ilib=syslib/');
utsb  23 ..s32u
utsb  24 .+s32v.
utsb  25      call getspp(inputfilename, 'i=sys$input/');
utsb  26      call getspp(printfilename, 'l=sys$output/');
utsb  27      call getspp(termfilename,  'term=sys$error/');
utsb  28      call getspp(inclibname,    'ilib=syslib/');
utsb  29 ..s32v
mtsa   8 .+s37cms.
      66      call getspp(inputfilename, 'i=sysin/');
ldsc  11      call getspp(printfilename, 'l=sysprint/');
dsi   63      call getspp(termfilename,  'term=systerm/');
dsc   54      call getspp(inclibname,    'ilib=syslib/');
mtsa   9 ..s37cms
mtsa  10 .+s37mts.
mtsa  11      call getspp(inputfilename, 'i=*source*/');
mtsa  12      call getspp(printfilename, 'l=*sink*/');
mtsa  13      call getspp(termfilename,  'term=*msink*/');
mtsa  14      call getspp(inclibname,    'ilib=syslib/');
mtsa  15 ..s37mts
utsa  49 .+s47.
utsb  30      call getspp(inputfilename, 'i=stdin/');
utsb  31      call getspp(printfilename, 'l=stdout/');
utsb  32      call getspp(termfilename,  'term=stderr/');
utsa  53      call getspp(inclibname,    'ilib=syslib/');
utsa  54 ..s47
      69 .+s66.
dsu   12      nameset 7nerxd$ns;  $ for abnormal termination dump.
dsu   13      size  atdopt(ws);  $ adnormal termination dump option.
dsu   14      data  atdopt = 0;  $ no dump by default.
dsu   15      end nameset;
dsu   16
dsu   17      call getipp(atdopt, 'dmp=0/1');  $ get termination dump option.
      70      call getspp(inputfilename, 'i=input/compile');
      71      call getspp(printfilename, 'l=output/list');
dsc   55      call getspp(termfilename,  'term=/term');
dsc   56      call getspp(inclibname,    'ilib=inclib/');
      72 ..s66
      73
      74      $   get parameters of standard print file.
      75
      76      call getipp(pflinelimit, pfdefaultlinelimit);
      77      call getipp(pfpagelimit, pfdefaultpagelimit);
      78      call getipp(pflinesperpage, pfdefaultlinesperpage);
dsk   31      call getipp(pflen, 'pfcl=0/80');
dsk   32      if  (pflen=0)  pflen = pflenmax;
dsk   33      if  (pflen>pflenmax)  pflen=pflenmax;
      79      call getipp(pfcarriage, 'pfcc=1/0');
      80      if  pflinelimit=0 & pfpagelimit>0  then
      81          pflinelimit = pfpagelimit * pflinesperpage;
      82          end if;
      83
      84      dblinelim = pflinelimit*9/10;  $ set monitor line limit.
      85
dsnc   7 $    get prompting character. the default value is system dependent.
dsnc   8 .+s10    call getspp(termprompt,'termp=*/');
dsnc   9 .+s11    call getspp(termprompt,'termp=>/');
dsnc  10 .+s32u   call getspp(termprompt,'termp=:/');
dsnc  11 .+s32v   call getspp(termprompt,'termp=>/');
dsnc  12 .+s37    call getspp(termprompt,'termp=>/');
dsnc  13 .+s47    call getspp(termprompt,'termp=:/');
dsnc  14 .+s66    call getspp(termprompt,'termp=>/');
dsna   2      if (termprompt.seq.'0') .len. termprompt=0;
dsna   3
      86      call ltllio(0);  $ initialize little io.
dsc   57
dsc   58      $   open terminal file if one desired.
dsc   59      if  (.len. termfilename)  call opnterm(termfilename);
dsk   34      call getipp(termh, 'termh=1/0');
dsk   35 .+s32   call getipp(termh, 'termh=0/1');
dsna   4 .+s47   call getipp(termh, 'termh=0/1');
      87
dsh   18 .-defenv_ss.
dsh   19 $    if using  library-defined string search primitives, call
dsh   20 $    blds to guarantee that ss namesets initialized.
dsh   21 $    do this by redundant, and harmless, construction of a string set.
dsh   22      call blds(' ', 1);
dsh   23 ..defenv_ss
      88      end subr ltlini;
smp    5 .+smps66.
smp    6      subr 7nsmpi$li;  $ smp execution initiator.
smp    7      $   retrieve program parameters 'smplo=0/0' and 'smphi=0/0'.
smp    8      $   if either nonzero, initiate smp request to generate
smp    9      $   execution profile.  as system will only accept request
smp   10      $   if job origin is 'system origin', issue dayfile
smp   11      $   messages before and after system request.
smp   12      $   smplo is first word address of area to monitor,
smp   13      $   smphi is last word address.
smp   14      size  memget(ws);
smp   15      size  smplo(ws), smphi(ws);
smp   16      size  wd(ws);
smp   17
smp   18      call getipp(smplo, 'smplo=0/0');
smp   19      call getipp(smphi, 'smphi=0/0');
smp   20
smp   21      if  (smphi>0) & (smplo(ynow+1)) return;  $ if expiration far in the future.
      14 $  expiration possible, find common origin for days, then determine
      15 $  days left until expiration.
      16      yorg = ynow;  if  (yorg>yexp)  yorg = yexp;  $ set origin.
      17      left = ((yexp-yorg)*365 + dexp) - ((ynow-yorg)*365+dnow);
      18      if  left <= 0  then  $ if expired
      19          textl('expired, obtain new copy.'); endl;
      21          call ltlfin(1, 1009); $ abnormally terminate.
      22      elseif left<30  then  $ if expiration approaching, warn user
      23          intl(left) textl(' days to expiration.') endl
      24          end if;
      25      end subr;
       1 .=member lcp
       2 $    lcp  ( l-ittle c-ompiler p-rint -procedures)
       3 $
       4 $    define the procedures used to generate the compiler list
       5 $    file.  these procedures perform needed conversions, building up a
       6 $    line as array of characters.
       7 $
       8      +*  putcn(c) =  $ add character to print line - no check
       9          pfl(pfcol) = c; pfcol = pfcol+1;
      10          **
      11
      12      +*  addc(c) =  $ add character to print line
      13          putcn(c);  $ add character
      14          if  (pfcol > pflen) call endlr;
      15          **
      16
      17      subr pagelr;           $ begin print file page.
      18      access lcpns;
      19      size  i(ps);            $ loop index.
      20      size  j(ps);            $ loop index.
dsk   36      size  pflsave(.sds. pflenmax);  $ saved print line (for titles).
      22      size  pflensave(ps);    $ saved length of pfl.
      23      size  pftermsave(1);  $ save -pftermflag-
      24      size  v(ps);            $ for converting page number.
      25
      26      pfpage = pfpage + 1;
      27      if  (pfpaging = 0)  return;
      28      pftermsave = pftermflag; pftermflag = no;  $ dont write title on t
      29      $   if page limit exceeded, suppress further carriage control.
      30      if  pfpagelimit  then
      31          if  (pfpage > pfpagelimit)  pfcarriage = 0;
      32          end if;
      33      if  pftitling  then  $ if title desired.
      34          pflensave = pfcol - 1;
      35          slen pflsave = pflensave; sorg pflsave = 1 + .sds. pflensave;
      36          do  i = 1 to pflensave;  .ch. i, pflsave = pfl(i); end do;
      37          do  i = 1 to slen pftitle;  pfl(i) = .ch. i, pftitle;  end do;
      38          if  pfpagefield  then  $ if page number desired.
      39              if  (pfpage<0)  pfpage = 0;
      40              if  (pfpage>9999) pfpage = 0;
      41              do  i = 0 to 4; pfl(pfpagefield+i) = 1r ;  end do;
      42              j = pfpagefield + 5;
      43              v = pfpage;
      44              until v = 0;
      45                  j = j - 1;
      46                  pfl(j) = charofdig( (v - 10*(v/10)) );
      47                  v = v / 10;
      48                  end until;
      49              end if;
      50          pfcol = slen pftitle+1;  call linelr;  $ print main title.
      51          do  i = 1 to slen pfstitle; pfl(i) = .ch. i, pfstitle; end do;
      52          pfcol = slen pfstitle + 1;  call linelr;  $ print sub title.
      53          call linelr;  $ print blank line after title.
      54          do  i = 1 to pflensave; pfl(i) = .ch. i, pflsave; end do;
      55          pfcol = pflensave + 1;
      56          pfl(1) = 1r ;
      57          pfline = 3;
      58      else
      59          pfl(1) = 1r1;       $ force start of new page.
      60          pfline = 0;
      61          end if;
      62      pftermflag = pftermsave;  $ save terminal flag
      63      end subr pagelr;
      64      subr etitlr(lin, str, posarg, lenarg);  $ enter string into title.
      65      $   enter string str in title line beginning at column pos.
      66      $   enter len characters, padding with blanks if str if shorter.
      67      $   use main title if lin is zero, else use subtitle.
      68      access lcpns;
      69      size  lin(ps);          $ line designator.
dsk   37      size  posarg(ws);       $ specified position to begin insert.
dsk   38      size  pos(ws);          $ position to insert.
      72      size  lenarg(ps);       $ number of positions to define.
      73      size  len(ps);          $ adjusted length.
dsk   39      size  str(.sds. pflenmax); $ string to insert.
      75      size  lc(ps);           $ last column index.
      76
      77      len = lenarg;  if  (len = 0)  len = slen str;
      78      pos = posarg;  if (pos<2) pos = 2;
      79      lc = pos + len - 1;  $ index of last column.
      80      if  (lc > pflen)  return;
      81      if  lin  then  $  if subtitle.
      82          if  (lc > slen pfstitle)  slen pfstitle = lc;
      83          .s. pos, len, pfstitle = str;
      84      else  $ if main title.
      85          if  (lc > slen pftitle)  slen pftitle = lc;
      86          .s. pos, len, pftitle = str;
      87          end if;
      88      end subr etitlr;
      89      subr ltitlr(tlabel);  $ prepare standard little title.
      90      access lcpns;
dsk   40      size tlabel(.sds. pflenmax);   $ title string.
      92      size  lstimestr(.sds. lstimelen);
      93      size  i(ps);  $ do loop index
      94
      95      call contlpr(6, 1);       $ set paging on.
      96      call contlpr(7, 1);       $ enable titling.
dsc   60      call etitlr(0, sitename, pflen-(63+sitenamelen), 0);
      98      call etitlr(0, '.little.', pflen-63, 0);
      99      $   copy at most first fifteen chars of supplied label.
     100      call etitlr(0, tlabel, pflen-55, 15);
     101      call etitlr(0, 'page', pflen-8, 0);
     102      call contlpr(8, pflen-4);  $ set page field.
     103      call contlpr(9, pflen-40);  $ set date field.
     104      pfpage = 0;  pfline = pflinesperpage;  $ at end of zero page.
     105      pfcol = 2;  pfl(1) = 1r ;
     106      pflinetotal = 0;
dsk   41      if  pftermopen & termh then  $ write header to terminal file
     108          pflistflag = no; pftermflag = yes;  $ this goes to terminal fi
     109          textl('start ') textl(sitename) textl('.little.')
     110          textl(tlabel)
     111          call lstime(lstimestr);
una    2          textl(lstimestr)   endl
     113          pflistflag = yes; pftermflag = no;  $ reset to normal
     114          end if;
     115      end subr ltitlr;
     116      subr stitlr(lin, titl);  $ enter title or subtitle.
     117      size  lin(ps);          $ zero for main title, else subtitle.
dsk   42      size  titl(.sds. pflenmax); $ title string.
     119      call etitlr(lin, titl, 2, 60);
     120      end subr stitlr;
     121      subr linelr;  $ end print line.
     122      access lcpns;
     123      size  lastline(1);      $ on when limit exceeded.
     124      size  i(ps);            $ loop index.
     125      size  iocc(ws);         $ io completion code.
     126
     127      if  (pfcol<2)  pfcol = 2;
     128      if  (pfcol > (pflen+1))  pfcol = pflen + 1;
     129      $   put blank in col 1 if no want carriage control.
     130      if  (pfcarriage = 0)  pfl(1) = 1r ;
     131      lastline = no;
     132      if  pflinelimit ^= 0 & pflistflag then  $  check for line limit
     133          pflinetotal = pflinetotal + 1;
     134          if  pflinetotal > pflinelimit  then
     135              lastline = yes;
     136              do  i = 1 to 20;
     137                  pfl(i+1) = .ch. i, 20qline limit exceeded.       ;
     138                  end do;
     139              pfcol = 22;
     140              end if;
     141          end if;
     142
     143      pfcol = pfcol - 1;  $ make true number of columns.
     144      if  (pflistflag)  call putcsio(2, iocc, pfl, 1, pfcol);
     145
     146      if  (pftermflag & pftermopen)    $ write line to terminal fil
     147          call putcsio(termfilenumber, iocc, pfl, 1, pfcol);
     148      pfcol = 2;
     149      pfl(1) = 1r ;
     150      if  lastline  then  $ note limit exceeded, and abort.
     151          call remarkl(' line limit exceeded.');
     152          call ltlfin(1, 1001);  $ line limit exceeded.
     153          end if;
     154      end subr linelr;
     155      subr endlr;             $ end print line.
     156      $   end print line.  if paging, see if must begin new page.
     157      access lcpns;
     158      size  newpage(1);       $ on to begin new page.
     159      if  (pfpaging = no)  then  call linelr;  return;  end if;
     160      newpage = no;
     161
     162      $   if no ouput to list file, dont count lines
     163      if  pflistflag = no then call linelr; return; end if;
     164
     165      if  pfl(1) = 1r  then
     166          if  (pfline = pflinesperpage)  newpage = yes;
     167      elseif  pfl(1) = 1r1  then  newpage = yes;
     168      elseif  pfl(1) = 1r0  then
     169          if  pfline >= (pflinesperpage-1)  then
     170              newpage = yes;  pfl(1) = 1r ;
     171          else  pfline = pfline + 1;  end if;
     172      elseif  pfl(1) = 1r+  then  pfline = pfline - 1;
     173          end if;
     174      if  (newpage) call pagelr; $ begin new page
     175      call linelr;
     176      pfline = pfline+1;
     177      end subr endlr;
     178      subr contlpr(act, arg);  $ control actions for print file.
     179      access lcpns;
     180      size  act(ps);          $ action to take.
     181      size  arg(ws);          $ parameter or result.
     182      size  i(ps);            $ loop index.
     183      size  lstimestr(.sds. lstimelen);  $ time-date string.
     184
     185      $   actions as follows.
     186      $   1   get current position in line.
     187      $   2   set current position in line.
     188      $   3   skip forward pos columns, inserting blanks on way.
     189      $   4   tab to column pos (add blanks on forward tab).
     190      $   5   new page action:
     191      $       if pos zero, begin new page.
     192      $       if pos not zero, begin new page if less than pos lines
     193      $       remain on current page.
     194
     195      $   6   set paging mode (if on, pages formed)
     196      $   7   set titling mode (if on, titles cleared).
     197      $   8   set page number field in title line.
     198      $   9   set date field in title line.
     199      $  10   get lines per page.
     200      $  11   set lines per page.
     201      $  12   get page number.
     202      $  13   set page number.
     203      $  14   get line number (within page).
     204      $  15   set line number (within page).
     205      $  16   get number of lines written.
     206      $  17   set number of lines written.
     207      $  18   get line limit.
     208      $  19   set line limit.
     209      $  20   get page limit.
     210      $  21   set page limit.
     211      $  22   get carriage control status.
     212      $  23   set carriage control status.
     213      $  24   get carriage control character.
     214      $  25   set carriage control character.
     215      $  26   set list output control flag.
     216      $  27   set terminal output control flag.
dsk   43      $  28   get terminal header flag.
dsk   44      $  29   set terminal header flag.
dsk   45      $  30   get characters per line.
     217
dsk   46      go to l(act) in 1 to 30;
     219
     220 /l(01)/
     221      arg = pfcol;        go to ret;
     222 /l(02)/
dsk   47      if  (arg<1 ! arg>pflen)  go to ret;
     223      pfcol = arg;        go to ret;
     224 /l(03)/  $ skip action
     225      if  (arg<1 ! arg>(pflen-1))   return;
     226      if  (arg+pfcol >= pflen)  then  call endlr;  return; end if;
     227      pfcol = pfcol + arg;
     228      do  i = 1 to arg;  pfl(pfcol-i) = 1r ;  end do;
     229      go to ret;
     230 /l(04)/  $ tab action.
     231      if  (arg=0)  go to ret;
     232      if  (pfcol >= arg)  then
     233          pfcol = arg;
     234      else
     235          while  pfcol < arg;
     236              pfl(pfcol) = 1r ;  pfcol = pfcol + 1;
     237              end while;
     238          end if;
     239      go to ret;
     240 /l(05)/  $ page action.
     241      if  pfpaging  then
     242          if  (arg=0) ! ((arg>0)&((arg+pfline)>pflinesperpage)) then
     243              call pagelr;
     244              end if;
     245          end if;
     246          go to ret;
     247 /l(06)/
     248      pfpaging = (arg ^= 0);  go to ret;
     249 /l(07)/
     250      pftitling = (arg ^= 0);
     251      if  pftitling  then  $ if titling, clear titles.
     252          sorg pftitle = 1 + .sds. pflen ;
     253          slen pftitle = pflen;
     254          .s. 1, pflen, pftitle = ' ';
     255          pfstitle = pftitle;
     256          slen pftitle = 1;
     257          .ch. 1, pftitle = 1r1;
     258          end if;
     259      go to ret;
     260 /l(08)/
dsk   48      if (arg<2)  go to ret;
     261      i = arg + 4;  $ index of last column.
     262      if  (i > pflen)  return;  $ if out of bounds.
     263      pfpagefield = arg;  $ set page field.
     264      if  (slen pftitle < i) slen pftitle = i;
     265      go to ret;
     266 /l(09)/
dsk   49      if (arg<2)  go to ret;
     267      i = arg + lstimelen - 1;  $ last column index.
     268      if  (i > pflen)  go to ret;  $ if out of bounds.
     269      pfdatefield = arg;
     270      if  pfdatefield  then  $ if date field, get date.
     271          call lstime(lstimestr);
     272          if  (slen pftitle < i)  slen pftitle = i;
     273          .s. pfdatefield, lstimelen, pftitle = lstimestr;
     274          end if;
     275      go to ret; $ set date field in title line.
     276 /l(10)/
     277      arg = pflinesperpage;  go to ret;
     278 /l(11)/
     279      if  (arg < 10)  go to ret;  $ avoid very small pages.
     280      pflinesperpage = arg;  go to ret;
     281 /l(12)/
     282      arg = pfpage;
     283      if  (pfline = pflinesperpage)  arg = arg + 1;  $ if at end of page
     284      go to ret;
     285 /l(13)/
     286      if  (arg > 9999)  go to ret;  $ avoid too large page number.
     287      pfpage = arg;           go to ret;
     288 /l(14)/  $   get line number of last line completed.
     289      arg = pfline;           go to ret;
     290 /l(15)/  $   set line number of last line completed.
     291      pfline = arg;           go to ret;
     292 /l(16)/  $   get number of lines written.
     293      arg = pflinetotal;      go to ret;
     294 /l(17)/  $   set number of lines written.
     295      pflinetotal = arg;      go to ret;
     296 /l(18)/  $   get line limit.
     297      arg = pflinelimit;      go to ret;
     298 /l(19)/  $   set line limit (zero to suppress limit check).
     299      pflinelimit = arg;      go to ret;
     300 /l(20)/  $ get page limit.
     301      arg = pfpagelimit;      go to ret;
     302 /l(21)/  $ set page limit.
     303      pfpagelimit = arg;      go to ret;
     304 /l(22)/  $ get carriage control condition.
     305      arg = pfcarriage;       go to ret;
     306 /l(23)/  $ set carriage control condition.
     307      pfcarriage = (arg ^= 0);  go to ret;
     308 /l(24)/  $ get carriage control character.
     309      arg = pfl(1);           go to ret;
     310 /l(25)/  $ set carriage control character.
     311      pfl(1) = arg;           go to ret;
     312 /l(26)/  $ set list output control flag.
     313      pflistflag = (arg ^= 0);  go to ret;
     314 /l(27)/  $ set terminal output control flag.
     315      pftermflag = (arg ^= 0);  go to ret;
dsk   50 /l(28)/  $ get terminal header flag.
dsk   51      arg = termh;  go to ret;
dsk   52 /l(29)/  $ set terminal header flag.
dsk   53      termh = (arg ^= 0);  go to ret;
dsk   54 /l(30)/  $ get characters per line.
dsk   55      arg = pflen;  go to ret;
     316 /ret/
     317      end subr contlpr;
     318      subr textlr(t);         $ print string.
     319      access lcpns;
dsk   56      size  t(.sds. pflenmax);   $ string to add.
     321      size  torg(ps);         $ origin of string.
     322      size  tlen(ps);  $ length in characters of string
     323      size  tpos(ps);  $ current position in string
     324      size  i(ps);  $ do loop index
     325      tlen = slen t;
     326 .+txtl_env.
     327      $   if possible, unpack string directly into pfl.
     328      if  pfcol+tlen <= pflen+1  then  $ if can unpack directly.
     329          call 7ntxtl$li(pfl, pfcol, t);
     330          pfcol = pfcol + tlen;
     331          if  (pfcol>pflen)  call endlr;
     332          return;
     333          end if;
     334 ..txtl_env
     335      tpos = sorg t;
     336      do i =  1 to  tlen;  $ print characters in turn
     337          tpos = tpos - cs; $ position to next character
     338          addc( (.f. tpos, cs, t))
     339          end do;
     340      end subr textlr;
     341      subr charlr(c);  $ print character.
     342      access lcpns;
     343      size  c(cs);  $ character to add
     344      addc(c);
     345      end subr charlr;
     346      subr octlr(o);  $ print octal value
     347      access lcpns;
     348      size  o(ws);  $ argument to output
     349
     350      call octlpr(o, (ws+2)/3);
     351      end subr octlr;
     352      subr wordlr(wordlarg);   $  print word
     353      access lcpns;
     354      size  wordlarg(ws);  $ word to output
     355      size  wordlch(cs);  $ character to output
     356      size  wordlpos(ps);  $ position in word
     357      size  i(ps);         $ do loop index
     358 $ adds characters in input word-size argument to output line
     359 .+unpk_env.   $ if possible, unpack directly into pfl.
     360      if  pfcol+cpw <= pflen+1   then
     361          call 7nunpk$li(pfl, pfcol, wordlarg, 1, cpw);
     362          pfcol = pfcol + cpw;
     363          if  (pfcol>pflen)  call endlr;
     364          return;
     365          end if;
     366 ..unpk_env
     367      wordlpos = (ws+1);
     368      while (wordlpos>cs);  $ process characters in turn
     369          wordlpos = wordlpos - cs;
     370          wordlch = .f. wordlpos, cs, wordlarg;
     371          addc(wordlch)
     372          end while;
     373      end subr wordlr;
     374      subr wordsr(ara, lo, hi);  $ print ara(lo) to ara(hi).
     375      size  ara(ws);  dims ara(2);
     376      size  lo(ps);           $ starting index.
     377      size  hi(ps);           $ ending index.
     378      size  i(ps);            $ loop index.
     379 .+unpk_env.  $ if possible, unpack directly into pfl.
     380      size  nc(ps);           $ number of characters.
     381      nc = (hi-lo+1) * cpw;
     382      if  pfcol+nc <= pflen+1  then  $ if can unpack.
     383          call 7nunpk$li(pfl, pfcol, ara, lo, nc);
     384          pfcol = pfcol + nc;
     385          if  (pfcol>pflen)  call endlr;
     386          return;
     387          end if;
     388 ..unpk_env
     389      do  i = lo to hi;
     390          call wordlr(ara(i));
     391          end do;
     392      return;
     393      end subr wordsr;
     394      subr intlr(intarg);    $ print integer value (5 digits).
     395      access lcpns;
     396      size  intarg(ws);
     397      call intlpr(intarg, 5);
     398      end subr intlr;
     399      subr tintlr(s, i);   $ print text and integer.
     400 $     put blanks before start and after end
     401      access lcpns;
     402      size  s(ws);  $ string to label integer
     403      size  i(ws);            $ integer to output
     404      addc(1r )  textl(s) textl(' = ') intl(i) addc(1r )
     405      end subr tintlr;
     406      subr intlpr(vin, cols);  $ print integer vin in cols columns.
     407 $    intlpr outputs a -cols- column integer value for input integer
     408 $    -vin-.  a new line is begun if less than -p- columns remain
     409 $    on the current line.  negative and large numbers are handled
     410 $    correctly, as is the integer -0 (peculiar to one's complements
     411 $    machines).
     412 $
     413      access lcpns;
     414      size  v(ws-1);  $ value to print, is nonnegative.
     415      size  vin (ws);  $ value to print
     416      size  colnow (ps);   $ current column being output
     417      size  ifminus(1);   $ set to 'yes' if negative input
     418      size  cols(ps);  $ columns to output
     419
     420      $   end current line if not room for integer.
     421      if  (cols < 1 ! cols > pflen) return;   $ bad call.
     422      if  (pfcol+cols > pflen+1)  call endlr;
     423      colnow = pfcol + cols;   $ index of last column defined.
     424      ifminus = (vin<0);  v = iabs(vin);
     425
     426      if  v<10  then  $ if only one digit.
     427          colnow = colnow - 1;
     428          pfl(colnow) = charofdig(v);
     429          v = 0;              $ indicate conversion complete.
     430      else
     431          while  v > 0 & colnow > pfcol;
     432              colnow = colnow - 1;
     433              pfl(colnow) = charofdig(mod(v,10));
     434              v = v / 10;
     435              end while;
     436          end if;
     437
     438      if  ifminus  then  $ if negative, insert minus sign.
     439          if  colnow > pfcol  then  $ if room for minus sign.
     440              colnow = colnow - 1;  pfl(colnow) = 1r-;
     441          else  v = 1;  end if;  $ if not room, force truncation error.
     442          end if;
     443
     444      if  (v)  pfl(pfcol) = 1r*;  $ if truncation.
     445
     446      do  colnow = colnow-1 to pfcol by -1;
     447          pfl(colnow) = 1r ;  end do;
     448
     449      pfcol = pfcol + cols;  $ set ending position.
     450      if  pfcol>pflen  then  $ if defined last char in line, write it.
     451          call endlr;
     452          end if;
     453      end subr intlpr;
     454      subr octlpr(w, c);  $ print -w- in -c- columns in octal.
     455 $    print word -w- in octal in no more than -c- columns.
     456      access lcpns;
     457      size  w(ws);  $ word to list
     458      size  c(ps);  $ no. of columns to output
     459      size  p(ps);  $ position in -w- during actual output
     460
     461      if  (c+pfcol > pflen+1)  call endlr;  $ if need new line.
     462      p = c*3 + 1;
     463      while p > 1;
     464          p = p - 3;  $ advance to next digit
     465 .+wsm3   putcn(charofdig((.f. p, 3, w)));
     466 .-wsm3.
     467          if  p = (ws/3)*3 + 1
     468              then  putcn(charofdig((.f. p, ws-(ws/3)*3,w)));
     469              else  putcn(charofdig((.f. p, 3, w)));
     470              end if;
     471 ..wsm3
     472          end while;
     473      end subr octlpr;
     474      subr hexlpr(hexarg, c);  $ print hexarg in hex using c columns.
     475 $    list c hexadecimal digits of hexarg
     476
     477      access lcpns;
     478      size  hexarg(ws);  $ value to list
     479      size  i(ps);  $ do loop index
     480      size  c(ps);  $ number of digits to list
     481      size  hextab(ps); dims hextab(16);  $ conversion table
     482      data  hextab = 1r0,1r1,1r2,1r3,1r4,1r5,1r6,1r7,1r8,1r9,1ra,1rb,1rc
     483          ,1rd,1re,1rf;
     484
     485      $   start new line if no room for constant.
     486      if  (pfcol+c > pflen+1)  call endlr;
     487      do  i = 1 to c;
     488          putcn(hextab(.f. (c-i)*4 + 1, 4,hexarg + 1));
     489          end  do;
     490      end subr hexlpr;
     491
     492      macdrop(addc)
     493      macdrop(putcn)
     494      $   end of lcp procedures.
       1 .=member getapp
       2      subr getapp(s, sl);  $ get actual parameter string.
       3      size  s(.sds. getapp_len);
       4      size  sl(ps);  $ maximum length of s.
       5      size  key(ps), code(ps), ifpres(ps), ifval(ps);
       6
       7      call reados(5, code, ifpres, ifval, sl, s);
       8
       9      end subr getapp;
       1 .=member getipp
       2      subr getipp(pvar, pstr);  $ get i-nteger p-rogram p-arameter.
       3      size  pvar(ws);         $ variable to receive value.
       4      size  pstr(.sds. (2*spplen));
       5      size  eqpos(ps);        $ index of '='.
       6      size  slpos(ps);        $ index of '/'.
       7      size  p1pos(ps);        $ index of start of value field.
       8      size  p2pos(ps);        $ index of end of value field.
       9      size  ifpres(1);        $ set if parameter present.
      10      size  ifval(1);         $ set if value specified.
      11      size  inval(ws);        $ set to numeric value if given.
      12      size  isval(.sds. spplen); $ set to string value if given.
      13      size  i(ps);            $ loop index.
      14      size  val(ws);          $ numeric value.
      15      size  plen(ps);         $ length of parameter code string.
dsb   26      size  d(ws);            $ digit during conversion.
      16
      17      plen = slen pstr;
      18      eqpos = '=' .in. pstr;  slpos = '/' .in. pstr;
      19      if  (slpos=0) return;
      20      if  (eqpos<=1 ! eqpos>=spplen) return;
      21
      22      call reados(1,(.s. 1, eqpos-1, pstr), ifpres, ifval, inval,isval);
dsh   24 .+s32v.
dsh   25 $    for vax vms, copy arg string and fold to upper case.
dsh   26      size  ustr(.sds. (2*spplen));
dsi   64      ustr = .s. 1, eqpos-1, pstr;
dsi   65      call stpc(ustr);  $ convert to primary case.
dsi   66      call reados(1,ustr, ifpres, ifval, inval,isval);
dsh   30 ..s32v
      23
      24      val = 0;
      25
      26      if  ifpres  then  $ if present.
      27          if  ifval  then  $ if value given, use it.
      28              pvar = inval;
      29              return;
      30          else  $ if present, no value, take alternate.
      31              if  (slpos = plen)  go to getstandard;
      32              p1pos = slpos+1;  p2pos = plen;
      33              end if;
      34      else  $ if not given, take standard default.
      35      /getstandard/
      36          p1pos = eqpos+1;  p2pos = slpos-1;
      37          end if;
      38
      39      do  i = p1pos to p2pos;
dsb   27          d = digofchar((.ch. i, pstr));  $ get value assuming digit.
dsb   28          if  (d<0 ! d>9)  cont do;  $ ignore if not digit.
dsb   29          val = 10*val + d;
      41          end do;
      42      pvar = val;
      43      return;
      44      end subr getipp;
       1 .=member getspp
       2      subr getspp(pvar, pstr);  $ get s-tring p-rogram p-arameter.
       3      size  pvar(.sds. spplen); $ variable to receive value.
       4      size  pstr(.sds. (2*spplen));
       5      size  eqpos(ps);        $ index of '='.
       6      size  slpos(ps);        $ index of '/'.
       7      size  p1pos(ps);        $ index of start of value field.
       8      size  p2pos(ps);        $ index of end of value field.
       9      size  ifpres(1);        $ set if parameter present.
      10      size  ifval(1);         $ set if value specified.
      11      size  inval(ws);        $ set to numeric value if given.
      12      size  isval(.sds. spplen); $ set to string value if given.
      13      size  i(ps);            $ loop index.
      14      size  val(ws);          $ numeric value.
      15      size  plen(ps);         $ length of parameter code string.
      16
      17      plen = slen pstr;
      18      eqpos = '=' .in. pstr;  slpos = '/' .in. pstr;
      19      if  (slpos=0) return;
      20      if  (eqpos<=1 ! eqpos>=spplen) return;
      21
      22      isval = '' .pad. spplen;
      23
      24
      25      call reados(3,(.s. 1, eqpos-1, pstr), ifpres, ifval, inval,isval);
dsh   31 .+s32v.
dsh   32 $    for vax vms, copy arg string and fold to upper case.
dsh   33      size  ustr(.sds. (2*spplen));
dsi   67      ustr = .s. 1, eqpos-1, pstr;
dsi   68      call stpc(ustr);  $ convert to primary case.
dsi   69      call reados(3,ustr, ifpres, ifval, inval,isval);
dsh   37 ..s32v
      26
      27      val = 0;
      28
      29      if  ifpres  then  $ if present.
      30          if  ifval  then  $ if value given, use it.
dsb   30              i = slen isval;
dsb   31              slen pvar = i;
dsb   32              if  i  then  $ copy value.
dsb   33                  sorg pvar = .sds. i + 1;
dsb   34                  .s. 1, i, pvar = .s. 1, i, isval;
dsb   35                  end if;
      32              return;
      33          else  $ if present, no value, take alternate.
      34              if  (slpos = plen)  go to getstandard;
      35              p1pos = slpos+1;  p2pos = plen;
      36              end if;
      37      else  $ if not given, take standard default.
      38      /getstandard/
      39          p1pos = eqpos+1;  p2pos = slpos-1;
      40          end if;
      41
dsb   36      if  p2pos >= p1pos  then
dsb   37          i = p2pos - p1pos + 1;  $ length to set.
dsb   38          slen pvar = i;  $ set length.
dsb   39          if  i  then  $ if value to copy.
dsb   40              sorg pvar = .sds. i + 1;
dsb   41              .s. 1, i, pvar = .s. p1pos, i, pstr;
dsb   42              end if;
dsb   43      else
dsb   44          slen pvar = 0;
      45          end if;
      46      return;
      47      end subr getspp;
       1 .=member lstime
       2 .-defenv_lstime.
       3      subr lstime(lst);  $  get character time.
       4      $   lstime determines characters representing current time.
       5      $   for example, the next to last second of 23 march 1976
       6      $   is represented as follows:
       7      $
       8      $       '   tue  23 mar 76  23.59.58   '
       9      $
      10      $       (123456789a123456789b123456789c) .
      11      $
      12      size  ca(cs);  dims ca(2);  $  user array of characters.
      13      size  nca(cs);  $ number of characters to enter in ca.
      14      size  ta(ps);  dims ta(8);  $ lntime array.
      15      size  i(cs);  $ loop index
      16      size  lst(.sds. lstimelen);  $ time string.
      17      size  names(sds((12+7)*3));  data names = $ day,month names
      18      'sunmontuewedthufrisatjanfebmaraprmayjunjulaugsepoctnovdec';
      19      size  mpos(ps), dpos(ps);  $ month, day positions in names.
      20      size  n(ps), ndiv10(ps);  $ for conversion.
      21
      22      call lntime(ta);  $ get numeric times.
dsu   18      lst = '' .pad. lstimelen;  $ intialize string.
      24      $   convert desired integers in lca.
      25      mpos = 3*ta(2) + 18;  $  names index of start of month name.
      26      ta(2) = ta(1) - 1900;  $  get last two digits of year.
      27      do  i = 14 to 26 by 3;  $ convert needed integers.
      28          n = ta(i/3-2);  ndiv10 = n/10;
      29          .ch. i, lst = charofdig(ndiv10);
      30              .ch. i+1, lst = charofdig((n - 10*ndiv10));
      31          end do;
      32          dpos = (ta(8)-1)*3;  $ position for day of week.
      33      do  i = 1 to 3;
      34          .ch. i+8, lst = .ch. i+16, lst;  $ move day.
      35          .ch. i+15, lst = .ch. i+13, lst;  $ move year.
      36          .ch. i+3, lst = .ch. dpos+i, names;
      37          .ch. i+11, lst = .ch. mpos+i, names;
      38          end do;
      39      .ch. 15, lst = 1r ;  .ch. 18, lst = 1r ;
      40      .ch. 22, lst = 1r: ;  .ch. 25, lst = 1r: ;
      41      end subr lstime;
      42 ..defenv_lstime
       1 .=member lctime
       2 .-defenv_lctime.
       3      subr lctime(lca, lcalen);  $ get string time as array of chars.
       4      size  lca(cs);  dims lca(2);  $ array of characters.
       5      size  lcalen(ps);       $ number of characters to receive.
       6      size  lststr(.sds. lstimelen);  $ time-date string.
       7      size  i(ps);            $ loop index.
       8      call lstime(lststr);  $ get string time.
       9      do  i = 1 to lcalen;
      10          if  (i>lcalen)  quit do;
      11          lca(i) = .ch. i, lststr;
      12          end do;
      13      do  i = lstimelen+1 to lcalen;  lca(i) = 1r ;  end do;
      14      return;
      15      end subr lctime;
      16 ..defenv_lctime
       1 .=member dumpaq
       2      subr dumpaq(text, array, low, high);
       3
       4      $   this procedure dumps 'array' from index 'low' to 'high',
       5      $   four elements per line.  the first line is blank, the next is
       6      $   'dump of array ' !! text, and the remaining contain the array
       7      $   elements.  each array element is preceded by its index in
       8      $   decimal.  the element is dumped in machine form.
       9      size  text(ws+1);    $ parameter, array name
      10      size  array(ws);     $ parameter, array to dump.
      11      size  low(ps);       $ parameter, starting index of array.
      12      size  high(ps);      $ parameter, ending index of array.
      13      size  l(ps);      $ current line number.
      14      size  index(ps);  $ current index being dumped.
      15      size  nlines(ps);       $ number of lines needed.
      16      +*  dumpentpl = $ number of entries per line.
      17      ((pflen-1)/(bwordlen+8)) **
      18      dims array(1);   $ dummy dimension.
      19
      20      endl      $ blank line
      21      textl(' dump of array ')  textl(text)  endl
      22
      23      nlines = (high-low+dumpentpl)/dumpentpl;      $ set number of line
      24
      25      do  l =  1 to  nlines;       $ loop for printing lines.
      26          index = l + low - 1;   $ initialize index.
      27
      28          while  index <= high;     $ place dumpentpl items in a line.
      29              charl(1r );         $ skip one space.
      30              intl(index);      $ output index in decimal.
      31              textl('. ');
      32              bwordl(array(index));    $ dump array element.
      33              index = index + nlines;   $ set index for next element.
      34              end while;
      35
      36          endl;   $  print a line
      37          end do;
      38
      39      return;
      40      macdrop(dumpentpl)
      41      end subr dumpaq;  $  dumpa
       1 .=member termio
dsc   61      subr opnterm(filename);  $ open terminal  file
       3      $   this procedure opens the terminal file used by the
       4      $   compiler, via -lcp-, to isolate error messages.
dsc   62      size  filename(sds(filenamelen));  $ file name
       6      size  iocc(ws);         $ io completion code.
       7      size  lenopn(ps);       $ line size obtained.
       8
       9      if  (pftermopen)  return;  $ do nothing if already open.
dsi   70       call eretsio(termfilenumber, iocc, yes);  $ set to return error.
      10      call opensio(termfilenumber, iocc, access_print,
dsc   63              filename, pflen, lenopn, 0, 0);
dsi   71      pftermopen = (iocc = 0);  $ show term file open if ok.
dsi   72       call eretsio(termfilenumber, iocc, no); $ set to quit on error.
      13      end subr opnterm;
      14      subr clsterm;  $ close term file if open.
      15      access lcpns;
      16      size  iorc(ps);         $ io return code.
      17      if  (pftermopen)  call clossio(termfilenumber, iorc);
      18      pftermopen = no;
      19      end subr clsterm;
       1 .=member linepak
       2 .-defenv_linepak.
       3      subr linepak(pa, ua, lchars);
       4 $    linepak takes the -nchars- characters in array ua which are
       5 $    unpacked (one char word) and packs theminto array -pa-
       6 $    the last wordof -pa- is filled with blanks, if appropriate.
       7
       8      size  pa(ws);  $ array into which we pack
       9      size  ua(cs);  $  input array of input chars
      10      size  lchars(ps);  $ num of chars to pack
      11      size  paword(ws);  $ packed word temporary
      12      size  paptr(ps);  $ pointer to pa
      13      size  papos(ps);  $ last position in paword being build
      14      size  i(ps);  $ do-loop temporary
      15      dims pa(2), ua(2);  $ dummy dims for parameters
      16
      17      paptr = 1;
      18      papos = (ws+1);  $ current position in pa
      19      paword = blankword;
      20      pa(1) = paword;
      21      do i =  1 to  lchars;   $  pack charactrs in turn
      22          papos = papos-cs;
      23          .f. papos, cs, paword = ua(i);
      24          if ( papos > 1) cont do;
      25          $ finished  current word
      26          pa(paptr) = paword;
      27          paword = blankword;
      28          paptr = paptr+1;
      29          papos = (ws+1);
      30          end do;
      31          $ if not packing integral no of words, store last word
      32      if (papos ^= ws+1) pa(paptr) = paword;
      33      end subr linepak;
      34 ..defenv_linepak
       1 .=member gobyerm
       2      subr gotoem(index);  $ prints diagnostic for bad goby index
       3
       4 $    this procedure is called from 7ngoto$er to print out diagnostic
       5 $    information after bad goby argument detected.
       6
       7      size  index(ws);        $ bad index value
       8
       9      endl  textl(' execution terminated - bad go to index ')
      10      intlp(mradix, 1) textl('b''') bwordl(index) charl(1r') endl
      11      call ltlfin(1, 1002);  $ bad go to index.
      12      end subr gotoem;
       1 .=member incio
       2      subr opninc(inputname, inimemname, includecode, updarg);
       3 /*
       4      open input file with included text processing.
       5      inputname is name of input file; if null, use standard
       6      input file.  if inimemname is not null, it is name of
       7      member to be included before reading input file.
       8      if includecode is not null, it gives the initial pattern
       9      which defines an include directive.
      10      updarg is nonzero if input lines from standard input file
      11      contain 8 characters of upd sequence information at the
      12      start of a line which is to be removed.
      13 */
      14
      15      $   inputname and inimemname are null to access default
      16      $   input and library files, respectively.
      17      size  inputname(.sds. filenamelen);  $ name of input file.
      18      size  inimemname(.sds. filenamelen);  $ name of initial member.
      19      size  includecode(.sds. filenamelen);  $ code for include.
      20      size  updarg(ps);      $ upd sequence option.
      21
      22      size  iname(.sds. filenamelen);
      23      size  i(ps), l(ps);     $ loop indexes.
      24
      25      nameset inclio;          $ globals for include processing.
      26      $   inclev is the inclusion level.  inclev is one when reading
      27      $   the standard input file.
      28      size  inclev(ps);  $ depth of inclusion.
dsc   64      data  inclev = 1;
      29
      30      $   filenow is sio file value for the current file.
      31      $   inpfile is the sio file value for the input file.
      32      $   incfile is the sio file value for the include library.
      33      $   incfile is initially zero, indicating that the include
      34      $   library is not yet open.  in this way opening the include
      35      $   library and allocation of buffers can be deferred until
      36      $   first include request seen.
      37      size  incfilenow(ps);  $ current file.
      38      size  incfile(ps);  size  inpfile(ps);
dsc   65      data  incfile = 0;  $ indicate file not open.
dsc   66      data  inpfile = 1;  $ standard input file.
      39
      40      $   lastpos(i) is the number of lines read at inclusion level i.
      41      $   lastpos is used to reposition within library when includes
      42      $   are nested.
      43      size  lastpos(.ps.); dims lastpos(inclevmax);
      44
      45      $   curpos is number of lines read since inclusion library
      46      $   opened or rewound.
dsc   67      size  curpos(ws);  data curpos = 0;
      48
      49      size  updseq(ps);     $ nonzero if upd sequence field.
      50      $   the string idcode contains the codes for the include and
      51      $   member directives.  idcodelen gives the lengths of the
      52      $   directives.
      53      size  idcode(.sds. 21);  $ codes for include and member
      54      data  idcode = ' .=include  .=member ';
      55      size  idcodelen(ps); dims idcodelen(2); data idcodelen = 11, 10 ;
      56
      57      $   memname is set by isidir to the member name if a directive
      58      $   seen.  a length of zero indicates directive not present.
      59      size  memname(.sds. filenamelen);
      60      data memname = '';
      61      $   memnext is set to name of next member when a member line is
      62      $   encountered during text inclusion.
      63      size  memnext(.sds. filenamelen);  data memnext = '';
      64      end nameset;
      65
      68      updseq =updarg;
      69
      70      $   copy code for include, at most 11 characters.
      71      l = slen includecode;
      72      if  (l < 3)  l = 0;  $ require at least three chars.
      73      if  (l > 11)  l = 11;
      74      do  i = 1 to l;
      75          .ch. i, idcode = .ch. i, includecode;
      76          end do;
      77      if  (l)  idcodelen(1) = l;
dsk   57 .+mc call stpc(idcode);  $ convert to primary case.
      78
      79      incfilenow = inpfile;  $ begin with input file.
      82      if  slen inimemname  then  $ if initial include, start it.
      83          memname = inimemname;
dsk   58 .+mc      call stpc(memname);  $ convert to primary case.
      84          call posinc(0);
      85          incfilenow = incfile;
      86          end if;
      87
      88      end subr opninc;
      89      subr clsinc;            $ close input (inclusion) file.
      90      access inclio;
      91      size  iorc(ps);         $ io return code.
      92      if  (incfile > 0)  call clossio(incfile, iorc);
      93      end subr clsinc;
      94      subr isidir(code,uara,ulo,uhi);  $ look for include or member.
      95      access inclio;
      96      $   code is 1 for include, 2 for member.
      97      $   build line.
      98      size  code(ps);         $ type of directive sought.
      99      size  uara(ws), ulo(ps), uhi(ps);  $ line is uara(lo) to uara(hi).
     100      dims  uara(2);
     101      size  uaralo(ws);       $ uara(ulo)
     102      size  c(cs);            $ character.
     103      size  line(.sds. (cpw*wpc));  $ sds form of line.
     104      size  linewds(ps);      $ words in line.
     105      size  ld(ps);           $ length of desired directive.
     106      size  i(ps);            $ loop indexes.
     107      size  porg(ps);         $ start of parameter.
     108      size  pend(ps);         $ end of parameter.
     109      size  plen(ps);       $ length of parameter.
     110      size  corg(ps);         $ origin of directive code in idcode.
     111      size  linemax(ps);
ldsd  11      size  anyc(ps),nayc(ps);     $ string search functions
dsk   59 .+mc  size  ctpc(cs);         $ converts to primary case
     112
     113      +*  lorg = (.sds. (cpw*wpc) + 1) **
     114
     115      $   look at first two characters in turn.  if they match,
     116      $   convert line to string and compare rest of characters.
     117      .len. memname = 0;       $ clear memname.
     118      corg = (code-1) * 11;
     119      uaralo = uara(ulo);
     120      c = .f. ws+1 - cs, cs, uaralo;  $ first char.
     121      if  (c ^= .ch. corg+1,idcode)  return;
     122      c = .f. ws+1 - 2*cs, cs, uaralo;  $ second char.
     123      if  (c ^= .ch. corg+2,idcode)  return;
     124      $   first two chars match, take the long route.
     125      linewds = (uhi-ulo+1);
     126      if  (linewds > wpc)  linewds = wpc;
     127      linemax = linewds * cpw;
     128      do  i = 1 to linewds;
     129          .f. lorg - i*ws, ws, line = uara(ulo+i-1);
     130          end do;
     131      sorg line = lorg;
     132      slen line = cpw * linewds;
     133      .ch. (cpw*linewds-1), line = 1r);  $ in case all blanks.
     134      .ch.  (cpw*linewds), line = 1r ;
dsk   60 .+mc call stpc(line); $ convert to primary case.
     135      ld = idcodelen(code);  if (ld = 2) go to found;
     136      do  i = 1 to ld;
dsd   10          $ fail by returning if no match.
dsk   61          if  (.f. lorg - i*cs, cs, line)
dsk   62               ^= (.ch.corg+i,idcode)  then  return; end if;
     139          end do;
     140      $   is desired card, get member name.
     141 /found/
     142      porg = 2;
ldsd  12      while nayc((.ch. porg, line) ,2);  $ skip to end of directive.
     144          porg = porg + 1;
     145          end while;
ldsd  13      while  anyc((.ch. porg, line), 2);  $ skip to start of member name
     147          porg = porg + 1;
     148          if  (porg > linemax) return;  $ if no name present, quit.
     149          end while;
     150      pend = porg;
ldsd  14      while  nayc((.ch. pend, line), 2);
     152          if  (pend > linemax) return;  $ if no name present, quit.
     153          pend = pend + 1;
     154          end while;
     155      pend = pend - 1;
     156      $   remove enclosing quotes or parentheses.
     157      porg = porg + ((.ch.  porg, line) = 1r');
     158      porg = porg + ((.ch.  porg, line) = 1r();
     159      pend = pend - ((.ch.  pend, line) = 1r');
     160      pend = pend - (.ch. pend, line = 1r));
     161      if  (porg > pend)  return;  $ if param is only quotes and parens,
     162      porg = porg - 1;
     163      plen = pend - porg;
     164      $   copy parameter name into member name, truncating long name.
     165      if  (plen > memnamelenmax)  plen = memnamelenmax;
     166      memname = .s. porg+1, plen, line;
     167      return;
     168      +* lorg = **
     169      end subr isidir;
     170      subr getinc(uara, ulo, uhi, udone);  $ read with include processin
     171      access inclio;
     172      size  uara(ws);  dims uara(2);   $ array to read.
     173      size  ulo(ps), uhi(ps);  $ read uara(lo) to uara(hi).
     174      size  udone(1);          $ set when end of input.
     175      size  endseen(ws);      $ end of data indicator.
     176      size  i(ps);
     177      size  iwd(ws);        $ dummy for read during skip.
     178
     179      $   read until line emerges or input exhausted.
     180      while 1;
     181          call getwsio(incfilenow,endseen,uara, ulo, (uhi-ulo+1)*cpw);
     182          $   see if need to move upd sequence information.
     183          if  endseen=no & updseq=1 & incfilenow=inpfile  then
     184              call updinc(uara, ulo, (uhi-ulo+1));
     185              end if;
     186          if  inclev > 1  then  $ if including, member is end.
     187              if  endseen = no  then
     188                  call isidir(2, uara, ulo, uhi);
     189                  endseen = (slen memname) > 0;
     190                  $ save name if including at first level.
     191                  if  endseen & inclev=2  then
     192                      memnext = memname;
     193                      end if;
     194                  curpos = curpos + 1;
     195              else  .len. memnext = 0; $ if no next member.
     196                  end if;
     197              end if inclev;
     198          if  endseen  then  $ if end, terminate if including, else done
     199              if  inclev = 1  then
     200                  udone = yes;
     201                  return;
     202              else
     203                  call posinc(1);  $ terminate include.
     204                  cont while;
     205                  end if inclev;
     206              end if endseen;
     207
     208          $ line read, look for include.
     209          call isidir(1, uara, ulo, uhi);
     210          if  slen memname  then  $ if include, save place, start includ
     211              call posinc(0);
     212              cont while;
     213          else
     214              quit while;
     215              end if;
     216          end while;
     217
     218      $   line available, return it.
     219
     220      udone = no;
     221      end subr getinc;
     222      subr posinc(ending);            $ position inclusion file.
     223      access inclio;
     224      $   begin inclusion.  increment inclusion level, locate desired
     225      $   member.  if member not found, issue warning and restore.
     226      $   ending is zero to begin include, one to terminate include.
     227      size  ending(ps);         $ nonzero to terminate.
     228      size  done(ws);         $ end of data indicator.
     229      size  i(ps);            $ loop index.
     230
     231      $   incline is the current line image.
     232      size  incline(ws); dims incline(wpc); $ line read in.
     233      size  iwd(ws);            $ dummy for read during skip.
     234      $   memwant is the desired member name when include begins.
     235      size  memwant(.sds. filenamelen);
     236      size  iorc(ps);         $ io return code.
     237      size  startsearch(ws);      $ starting position for search.
     238      size  eofok(ps);          $ flag for search.
     239
     240      if  (ending)  go to restoreit;
     241      memwant = memname;  $ save desired member name.
     242      if  incfile = 0  then  $ if include file not opened, open it.
     243          call opensio(incfilenumber, iorc, access_get,
     244              inclibname, cpw*wpc, i, 0, 0);
dsl    8          if  iorc  then  $ if unable to open.
dsla   2              call remarkl(inclibname);
dsl    9              textl('error - unable to open inclusion file ')
dsl   10              textl(inclibname)  endl
dsl   11              call ltlfin(1,1010);
dsl   12              end if;
     245          incfile = incfilenumber;
     246          end if;
     247
     248      lastpos(inclev) = curpos;  $ save position within library.
     249      inclev = inclev + 1;
     250      incfilenow = incfile;
     251      if  inclev > inclevmax  then  $ if depth too great, abort.
     252          textl('maximum include depth exceeded.') endl
     253          call ltlfin(1, 1003);  $ inclusion depth too great.
     254          end if;
     255
     256      $   if prior include terminated by encountering member line for
     257      $   member now desired, can just continue reading.
     258      if  (memwant .seq. memnext)  return;
     259      .len. memnext = 0;  $ else reset memnext.
     260      eofok = yes;  $ ok to search past eof.
     261      startsearch = curpos;  $ starting point for end-around search.
     262
     263      while 1;
     264          call getwsio(incfile, done, incline, 1, wpc*cpw);
     265          if  done  then
dsd   14              if  (eofok=no)  quit while;
     267              eofok = no;  $ indicate part 1.
     268              call rewisio(incfile, iorc, 0);
     269              curpos = 0;  $ indicate at start of file.
     270              cont while;
     271              end if;
     272          curpos = curpos + 1;
dsd   15          if  (eofok=no & curpos>startsearch)  quit while;
     274          call isidir(2, incline, 1, wpc);  $ look for member line.
dsd   16          if  (memwant .seq. memname)  return;
     276          end while;
dsd   17      $ member not present, print warning and restore.
     280      textl(' ***error***  member ') textl(memwant)
     281      textl(' not found, include ignored.') endl
     282 /restoreit/
     283      inclev = inclev - 1;
     284      if  inclev > 1  then  $ if still including, restore pl
     285          if  lastpos(inclev)<= 0) ! (crfnum > 9)  then  $ if bad num. param.
      14          textl('crfnam - bad file number ') intl(crfnum) endl
      15          go to crfabt;
      16          end if;
      17      crfname = crfparm;
      18      do  l = slen crfparm to 1 by -1;
      19          c = .ch. l, crfname;
      20          do  i = 1 to 10;
      21              if  .ch. i, '0123456789' = c  then
      22                  .ch. l, crfname = charofdig(crfnum);
      23                  return;
      24                  end if;
      25              end do;
      26          end do;
      27      $   error numeric to substitute not found.
      28      textl('crfnam - missing numeric character in file name ')
      29      textl(crfname)  endl
      30 /crfabt/
      31      call ltlfin(1, 1004);  $ bad reference file name.
      32      end subr crfnam;
       1 .=member reados
       2      subr reados(key, code ,ifpres, ifval, inval, isval);$ read options
       3      /*
       4      obtain the user-supplied option string.
       5      parameters are as follops:
       6      key - desired action
       7          1 - integer valued parameter
       8          2 - octal valued parameter
       9          3 - string valued parameter
      10          4 - set inval to number of parameters and return
      11          -i - set ifpres if i-th parameter available; if so, set
      12              code to parameter, isval to value.
      13      code - string giving parameter code
      14      ifpres - switch indicating if parameter present
      15      ifval - switch indicating if value supplied.
      16      inval - numeric value given (key = 1,2)
      17      isval - string value given (key=3)
      18
      19      the parameter string is obtained by the procedure -readsos-
      20      which returns the parameter string as an array of characters.
      21      the parameter string may not contain internal instances of , or );
      22      blanks are ignored.
      23          */
      24
      25      size  key(ws);  $ option desired
      26      size  code(sds(ospmax)); $ parameter code
      27      size  ifpres(1);  $ set on if parameter supplied
      28      size  ifval(1);  $ set if value supplied
      29      size  inval(ps);  $ supplied numeric value
      30      size  isval(sds(ospmax));  $ supplied string value
      31      size  cc(ps);  dims cc(oscmax); $ character array holding string
      32      size  cclen(ps); data cclen = oscmax-1; $ length of supplied str.
      33      size  nparms(ps); data nparms=0;  $ number of supplied parameters
      34      size  ip(ps);  $ parameter index
      35      size  i(ps), l(ps);  $ loop indices, lengths
      36      size  c(ps);  $ current character
      37      size  firstcall(1); data firstcall=1; $ to trap first call
      38      size  porg(ps);  $ index of start of parameter, 0 if no proaram
      39      size  vorg(ps);  $ index of start of value, 0 if no value
      40      size  plen(ps);  $ number of characters in parameter
      41      size  vlen(ps);  $ number of characters in value portion
      42      size  inc(ps);  $ 1 when inside parameter, 0 when in value part
      43      size  ccp(ps);  $ position in cc
      44      size  base(ps);  $ arithmetic base for numeric conversion
dsb   45      size  d(ws);            $ digit value during numeric conversion.
plf   20 .+plf1  size passcom(1);  $ on to pass commas to argument
      45
      46      if  firstcall then  $ if first time, get param string
      47          firstcall = 0;
      48          call readsos(cc, cclen);  $ cclen set to length of string
      49              $ on entry gives maximum allowed.
dsf   51
      50          cclen = cclen+1; cc(cclen) = 1r, ;
      51          /* terminal , simplifies scan */
plf   21 .+plf0.
      52          do  i = 1 to cclen; nparms = nparms + (cc(i)=1r,); end do;
plf   22 ..plf0
plf   23 .+plf1.
plf   24 $    take comma as separator, unless between [ (or <) and ] (or>).
plf   25      passcom = no;
plf   26      do  i = 1 to cclen;
plf   27          c = cc(i);
dsn   18          if (c=1r[ ! c=1r< ! c=1r() & passcom=no  then
dsn   19              passcom = yes;
dsn   20          elseif  (c=1r] ! c=1r> ! c=1r)) & passcom=yes then
dsn   21              passcom = no;
plf   30          elseif  (c=1r,) & passcom = no then nparms = nparms+1;
plf   31          end if;
plf   32          end do;
plf   33 ..plf1
      53          end if;
      54
      55      if  key=4  then  $ if want number of parameters available
      56          inval = nparms;  return;  end if;
      57
dsc   68      if  key=5  then  $ if want full parameter string.
dsc   69          l = cclen-1;  $ determine number of chars to copy.
dsc   70          if  (l > inval)  l = inval;  $ if actual string too long.
dsc   71          .len. isval = l;  $ set length of result.
dsc   72          sorg isval = 1 + (.sds. l);
dsc   73          do  i = 1 to l;  $ copy into isval.
dsc   74              .ch. i, isval = cc(i);
dsc   75              end do;
dsc   76          return;
dsc   77          end if;
dsc   78
      58      ifpres = 0;  ifval = 0;  inval = 0; ccp = 0;
      59
plf   34 .+plf1  passcom=no;
      60      do  ip = 1 to nparms;
      61          porg = ccp; vorg = 0; plen = 0; vlen = 0;
      62          inc = 1; $ 1 when inside parameter, 0 when inside val
      63          while 1;  $ scan parameter
      64              ccp = ccp + 1;
plf   35 .+plf0.
      65              if  (cc(ccp)=1r,)  quit while; $ end seen
plf   36 ..plf0
plf   37 .+plf1.
plf   38 $    take comma as separator, unless between [ (or <) and ] (or>).
plf   39              c = cc(ccp);
dsn   22               if  (c=1r[ ! c=1r< ! c=1r() & passcom=no  then
dsn   23                  passcom = yes;
dsn   24                elseif  (c=1r] ! c=1r> ! c=1r)) & passcom=yes  then
dsn   25                  passcom=no;
plf   42              elseif  (c=1r,)&(passcom=no) then quit while;
plf   43              end if;
plf   44 ..plf1
      66              if  (cc(ccp) = 1r= )  then $ switch to value part
      67                  vorg = ccp; inc = 0; cont while; end if;
      68              plen = plen + inc;  vlen = vlen + (1-inc);
      69              end while;
      70
      71          if  key = -ip  then  $ if want this parameter
      72              ifpres = 1;  ifval = (vlen ^=0);
      73              l = slen code;  if  (l>plen) l=plen;
      74              do  i = 1 to l;
      75                  .ch. i, code = cc(porg+i);  end do;
      76              slen code = l;
      77              l = slen isval;  if (l>vlen) l=vlen;
      78              do  i = 1 to l;
      79                  .ch. i, isval = cc(vorg+i);  end do;
      80              slen isval = l;
      81              return;
      82              end if;
      83
      84          if  key>0  then  $ if looking for param, this may be it
      85              if  slen code ^= plen  then cont do; end if;
      86              do  i = 1 to plen;
      87                  if  (.ch. i, code ^= cc(porg+i)) cont do ip;
      88                  end do;
      89              $ parameter found, process value
      90              ifpres = 1;
      91              ifval = (vlen ^= 0);
      92              go to l(key) in 1 to 3;
      93          /l(1)/  base = 10; go to conv;
      94          /l(2)/  base = 8;
      95          /conv/  $ convert numeric value
      96              do  i = 1 to vlen;
dsb   46                  d = digofchar(cc(vorg+i));  $ get value if digit.
dsb   47                  if (d<0 ! d>9)  cont do;  $ ignore if not digit.
dsb   48                  inval = inval*base + d;
      98                  end do;
      99              return;
     100          /l(3)/
     101              l = vlen;
     102              if  (l>slen isval)  l = slen isval;
     103              do  i = 1 to l;
     104                  .ch. i, isval = cc(vorg + i);  end do;
     105              slen isval = l;
     106              return;
     107              end if;
     108
     109          end do ip;
     110      /* if reach here, parameter not found */
     111      end subr reados;
       1 .=member ltlxtr1
dsv   81 .+s10.
dsv   82      subr ltlxt1;  $ dummy ltlxt1 for completion by mccann.
dsv   83      end subr ltlxt1;
dsv   84 ..s10
dsv   85 .+s11.
dsv   86      subr  ltlxt1(cursp, initsp);  $ produce trace back chain.
dsv   87      $   this procedure is invoked by -ltlxtr- when a listing of
dsv   88      $   the current trace back chain is desired.
dsv   89      size  cursp(ws);            $ stack pointer at time of call.
dsv   90      size  initsp(ws);           $ stack pointer at program init.
dsv   91
dsv   92      size  7nmget$li(ws);        $ memory read routine.
dsv   93      size  scanptr(ps);          $ current scanning position in stack.
dsv   94      size  endscan(ps);          $ highest address in stack.
dsv   95      size  tempadr(ps);          $ temporary.
dsv   96      size  i(ps);                $ temporary.
dsv   97      size  calladr(ps);          $ address of -call-.
dsv   98      size  ascii(cs);            $ array to hold routine names.
dsv   99      dims  ascii(9);             $ number of chars in routine name.
dsv  100
dsv  101      scanptr = .f. 2, ps, cursp;  $ get word value of stack pointer.
dsv  102      endscan = .f. 2, ps, initsp;  $ get initial word initial stack ptr
dsv  103      endl;  endl;  $ leave two blank lines.
dsv  104      textl('trace back chain')  endl  endl  $ print heading.
dsv  105
dsv  106      $   now scan the programs stack looking for the address of calls.
dsv  107      until  scanptr = endscan;  $ until scan completed.
dsv  108          tempadr = 7nmget$li(scanptr);  $ get contents of stack.
dsv  109          tempadr = .f. 2, ps, tempadr;  $ get word address value.
dsv  110          if  7nmget$li(tempadr-2) = 3b'4767' then  $ could be -call-.
dsv  111              calladr = tempadr - 2;  $ get address of call statement.
dsv  112              $   now get address of called routine.
dsv  113              tempadr = tempadr - 3 + .f. 2, ps, (7nmget$li(tempadr-1));
dsv  114              if  7nmget$li(tempadr+3) = 3b'4567' then  $ is call.
dsv  115                  call  6nrad$li(tempadr, ascii);  $ convert rad50 -> as
dsv  116                  do  i = 1 to 9;  $ write out routine name.
dsv  117                      if  (ascii(i) = 1r ) quit do;  $ if end of name -
dsv  118                      charl(ascii(i))  $  write out this part of name.
dsv  119                      end do i;
dsv  120
dsv  121                  textl(' called from location ')
dsv  122                  octlp(calladr, 6)  endl  $ end line.
dsv  123                  end if;
dsv  124              end if;
dsv  125
dsv  126          scanptr = scanptr + 1;  $ back up stack.
dsv  127          end until;
dsv  128
dsv  129      end subr ltlxt1;
dsv  130 ..s11
       2 .+s66.
       3      subr ltlxtr1(locfrom);  $ print part of trace back package
       4 $    this procedure prints subroutine trace back chain as diagnostic ai
       5 $    is it called from ltlxtr, which sets up argument locfrom as
       6 $    location of most recent call.
       7 $    implementation is necessarily system-dependent.
       8
       9 $    this cdc version assumes ftn calling conventions have been used,
      10 $    and traces back at most 20 levels.
      11
      12      size  locfrom(ws);      $ location of most recent call
      13      size  memget(ws);      $ returns contents in indicated memory wd.
      14      size  loc(ws);          $  current location
      15      size  levels(ws);       $ number of procedures traced back
      16      size  lineno(ws);       $ line number withing procedure
      17      size  name(ws);         $ entry word
      18      size  memname(ws);      $ memget(name)
      19      size  ientry(ws);       $ header word for procedure
      20      size  mentry(ws);       $ memget(ientry)
      21      size  lname(ws);        $ display code name of procedure
      22      size  memloc(ws);     $ value of current loc
      23
      24      loc = locfrom;  levels = 0;
      25      endl textl(' trace back chain') endl
      26 /next/
      27      memloc = memget(loc);  $ word with call
      28      if .f. 49, 12, memloc ^= 3b'0100' then
      29          $ quit if not subroutine call (return jump)
      30          return;  end if;
      31      levels = levels + 1;  if (levels >20) return;
      32          $  avoid tracing too much, or infinite loop if core clobberec
      33      lineno = .f. 19, 12, memloc;  $ line number of call
      34      name = .f. 1, 18, memloc;  $ addr of header word for procedure
      35          memname = memget(name);  $ header word for procedure
      36      ientry = .f. 1, 18, memname;  $ true entry word
dsv  131      if  (ientry=0)  ientry = name+1;  $ if cdc quirk.
      38      mentry = memget(ientry);
      39      lname = memname;  .f. 1, 18, lname = 3r   ; $ display code name
      40
      41      textl(' called by ')  wordl(lname)  textl('  at line ')
      42          intl(lineno) textl(', location ') addrl(loc) endl
      43
      44      if .f. 49, 12, mentry ^= 3b'0400' then
      45          $  quit if no further calls to process
      46          return;  end if;
      47      loc = .f. 31, 18, mentry-1;  $ address of previuus call
      48      go to next;
      49
      50      end  subr ltlxtr1;
      51 ..s66
       1 .=member ltlregl
       2      subr ltlregl(regs);     $ list machine register contents
       3
       4 $    this system-dependent procedure lists contents of machine register
       5 $    contents, and is used for diagnostic purposes.
       6 $    called from ltlregs, which sets up -regs- in system-dependent way.
       7
       8 .+s10.
       9      size  regs(ws); dims regs(16); $ general registers.
      10      size  i(ps);  $ loop index.
      11
      12      endl textl('register contents') endl
      13      do  i = 1 to 16;
      14          if  i > 10 then  textl('  r') intlp(i-1,2)
      15              else  textl('   r') intlp(i-1,1)  end if;
      16          textl('  ')
      17          bwordl(regs(i))
      18          if (mod(i, 4) = 0) endl  $ four registers per line.
      19          end do;
      20 ..s10
      21 .+s11.
      22      size  regs(ws);         $ define register array.
      23      dims  regs(8);
      24      size  i(ps);            $ temporary.
      25
      26      endl
      27      textl('contents of registers')  endl  $ title output.
      28      do  i = 1 to 6;  $ loop until registers are done.
      29          textl('  r')  intlp(i-1, 1)  textl('  ') $ identify register.
      30          bwordl(regs(i))   $ print contents of register.
      31          if  (mod(i, 4)=0) endl  $ 4 registers per line
      32          end do;
      33
      34      textl('   sp  ')  bwordl(regs(6))  endl
      35 ..s11
vax   23 .+s32.
vax   24      size  regs(ws); dims regs(16); $ general registers.
vax   25      size  i(ps);  $ loop index.
vax   26
vax   27      endl textl('contents of general purpose registers.') endl
vax   28      do  i = 1 to 16;
vax   29          if  i > 10 then  textl('  r') intlp(i-1,2)
vax   30              else  textl('   r') intlp(i-1,1)  end if;
vax   31          textl('  ')
vax   32          bwordl(regs(i))
vax   33          if (mod(i, 4) = 0) endl  $ four registers per line.
vax   34          end do;
vax   35 ..s32
      36 .+s37.
      37      size  regs(ws); dims regs(16); $ general registers.
      38      size  i(ps);  $ loop index.
      39
      40      endl textl('contents of general purpose registers.') endl
      41      do  i = 1 to 16;
      42          if  i > 10 then  textl('  r') intlp(i-1,2)
      43              else  textl('   r') intlp(i-1,1)  end if;
      44          textl('  ')
      45          bwordl(regs(i))
      46          if (mod(i, 4) = 0) endl  $ four registers per line.
      47          end do;
      48 ..s37
utsa  62 .+s47.
utsa  63      size  regs(ws); dims regs(16); $ general registers.
utsa  64      size  i(ps);  $ loop index.
utsa  65
utsa  66      endl textl('contents of general purpose registers.') endl
utsa  67      do  i = 1 to 16;
utsa  68          if  i > 10 then  textl('  r') intlp(i-1,2)
utsa  69              else  textl('   r') intlp(i-1,1)  end if;
utsa  70          textl('  ')
utsa  71          bwordl(regs(i))
utsa  72          if (mod(i, 4) = 0) endl  $ four registers per line.
utsa  73          end do;
utsa  74 ..s47
      49 .+s66.                       $ cdc 6000 series...
      50      $   -regs- contains registers in order a0-a7, b0-b7, x0-x7.
      51      size  regs(ws);  dims regs(24);
dsv  132 .+s10.
dsv  133      size  regs(ws); dims regs(16); $ general registers.
dsv  134      size  i(ps);  $ loop index.
dsv  135
dsv  136      endl textl('contents of general purpose registers.') endl
dsv  137      do  i = 1 to 16;
dsv  138          if  i > 10 then  textl('  r') intlp(i-1,2)
dsv  139              else  textl('   r') intlp(i-1,1)  end if;
dsv  140          textl('  ')
dsv  141          bwordl(regs(i))
dsv  142          if (mod(i, 4) = 0) endl  $ four registers per line.
dsv  143          end do;
dsv  144 ..s10
      52      size  i(ps);            $ do loop index
      53
      54      endl  textl(' contents of machine registers ')  endl
      55      do i = 1 to 8;
      56          textl('    a') intlp(i-1,1) skipl(2)
      57          addrl(regs(i))
      58          textl('   b') intlp(i-1,1) skipl(2)
      59          addrl(regs(i+8))
      60          textl('    x') intlp(i-1,1) skipl(2)
      61          bwordl(regs(i+16))
      62          endl
      63          end do;
      64 ..s66
      65
      66      end subr ltlregl;
       1 .=member readsos
       2 .-defenv_readsos.
       3      subr readsos(cc, cclen);  $ obtain option string from system
       4
       5      /*  this system-dependent procedure obtains the option string.
       6          the string is entered as an array of characters in -cc-.
       7          on entry, cclen gives maximum characters that may be set;
       8          on exit, cclen is the number of characters in the string.
       9          */
      10
      11      size  cc(ws); dims cc(2);  $ array of option characters
      12      size  p(ws);  $ length of option string
      13      size  cclen(ws);  $ max. length of option string on entry,
      14          $ true length on exit.
      15
      16      p = 0;  $ assume no option string supplied.
      17
      18 .+s66.
      19      /*  for cdc 6000 systems, we require that the user supply the
      20          string enclosed in parentheses after the standard execution
      21          header, as in  'little(in,out)  (optionstring)'.
      22          the system places the string in absolute locations 70-77b,
      23          marking the end of string with a 00 byte.  our job here
      24          is to skip past the prefix, which is terminated by . or ),
      25          then to locate the ( marking the start of the list, and
      26          finally accumulate options until ) seen.
      27          we use a simple automaton to record our status.
      28
      29      memget is a library procedure which reads absolute core.
      30
      31          */
      32      size  i(ps), j(ps);  $ loop indices
      33      size  memget(ws);  $ system function to read core
      34      size  iwd(ws);  $ last value returned by memget
      35      size  c(ws);  $ current character
      36      size  state(ws);  $ current state
      37
      38      /*  states are encoded as follows :
      39          1 - looking for . or ) at end of prefix
      40          2 - looking for ( at start of list
      41          3 - looking for ) ending list    */
      42
      43      state = 1;  $ begin looking for end of prefix
      44      p = 0;  $ no characters yet in cc
      45
      46      do  i = 1 to 8;
      47          iwd = memget(3b'67'+i);  $ next word from low core
      48          do  j = ws-cs+1 to 1 by -cs; $ get characters
      49              c = .f. j, cs, iwd;
      50              if  (c=0)  quit do i;  $ if end.
      51              if  state=1  then
      52                  if  (c=1r. ! c=1r))  state=2;
      53              elseif  state=2  then
      54                  if  (c=1r()  state = 3;
      55              else  $ if state=3.
      56                  if  (c=1r))  quit do i;
      57                  if  p < cclen  then  $ if room for character.
      58                      p = p + 1;  cc(p) = c;
      59                      end if;
      60                  end if;
      61              end do j;
      62
      63          end do i;
      64
      65 ..s66
      66
      67      cclen = p;
      68
      69      end subr readsos;
      70 ..defenv_readsos
       1 .=member ltlfin
       2      subr ltlfin(abnormal, completioncode);
       3      $   terminate execution, abnormally if -abnormal- not zero.
       4      $   completion code is passed on to host terminator.
       5      size  abnormal(ws);     $ nonzero if abnormal termination.
       6      size  completioncode(ws);  $ completion code.
       7     $ sflev and sfcod are completion values passed to sysfin.
       8     $ sflev is the largest (most severe) value encountered during
       9     $ execution of ltlfin, and sfcod is code passed first time that
      10     $ level encountered.
      11     size sflev(ws), sfcod(ws);
      12     data sflev=0;
      13     data sfcod=0;
      14      size  i(ps);             $ index, current line limit.
      15
      16 .+s10  size  ncalls(ps);  data ncalls = 0;  $ number of -ltlfin- calls.
      17 .+s11  size  ncalls(ps);  data ncalls = 0;  $ number of -ltlfin- calls.
      18 .+s32  size  ncalls(ps);  data ncalls = 0;  $ number of -ltlfin- calls.
      19 .+s66  size  ncalls(ps);  data ncalls = 0;  $ number of -ltlfin- calls.
      20 .+s37.
      21      $   on s37, put termination variables in a nameset.
      22      +*  exitns = 7nexit$ns **
      23      nameset  exitns;  $ start the nameset.
      24      size  ncalls(ps);  data ncalls = 0;  $ number of -ltlfin- calls.
      25      size  pgmckflg(1); data pgmckflg = no;  $ recursion preventor.
      26      size  sioerflg(1); data sioerflg = no;  $ ditto
      27      end nameset;
      28 ..s37
      29 .+s47.
      30      $   on s47, put termination variables in a nameset.
      31      +*  exitns = 7nexit$ns **
      32      nameset  exitns;  $ start the nameset.
      33      size  ncalls(ps);  data ncalls = 0;  $ number of -ltlfin- calls.
      34      size  pgmckflg(1); data pgmckflg = no;  $ recursion preventor.
      35      size  sioerflg(1); data sioerflg = no;  $ ditto
      36      end nameset;
      37 ..s47
      38
      39      ncalls = ncalls + 1;
      40
      41 .+erexit   if (ncalls<4)  call 7nerxi$si;
      42
      43      if  ncalls = 1  then  $ if first call, try to terminate.
      44          sflev = abnormal;
      45          sfcod = completioncode;
      46          if  abnormal  then
      47              call contlpr(21, 0);  $ set page limit to zero.
      48
      49              call contlpr(18, i);  $ get current line limit.
      50              if  i  then  $ if line limit set, extend by 2000 lines.
      51                  call contlpr(19, i+2000);
      52                  end if;
      53
      54 .+s32         if abnormal=1 then $ traceback only if little error.
      55              call ltlxtr;  $ list trace back chain.
      56 .+s32        end if;
      57
      58              $ increment ncalls so can close files.
      59              ncalls = ncalls + 1;
      60              call usratp; $ call user abnormal termination procedure.
      61          else  $ if normal, increment ncalls so can close.
      62              ncalls = ncalls + 1;
      63
      64 .+extime.  $ following text computes and writes elapsed time.
      65
      66      size  timeoff(letimesz);  $ end of job time.
      67
      68      if  etim  then  $ if want elapsed time.
      69      call letime(timeoff);  timeoff = timeoff - timeon;
      70 .+s11    timeoff = (timeon*1000)/60;
      71      size msg(sds(38));  $ sds for execution time message
      72      data msg = '     0.000 cpu seconds execution time.';
      73      size  t10(letimesz);    $ temporary for time output.
      74      size  pos(ps);  $ position in output message
      75
      76      pos = 10;
      77      while  timeoff;
      78          t10 = timeoff/10;
      79          .ch. pos, msg = charofdig( timeoff - 10*t10);
      80          pos = pos-1;
      81          if (pos=7) pos = 6; $ skip across decimal point
      82          timeoff = t10;
      83          end while;
      84 .+s66  call remarkl(msg); $ put etim in dayfile
      85 .-s66.
      86      $ put elapsed time on listing file.
      87      call textlr(msg); call endlr; $ write to listing.
      88 ..s66
      89      end if etim;
      90 ..extime
      91              end if abnormal;
      92
      93      else
      94      $ if not first call, reset level if
      95      $ level of greater severity than any yet seen.
      96          if  abnormal > sflev  then
      97              sflev = abnormal;
      98              sfcod = completioncode;
      99              end if;
     100          end if ncalls;
     101
     102      if  ncalls=2  then  $ if can try to close files.
     103          call ltllio(1);      $ terminate little io.
     104          ncalls = ncalls + 1;
     105          end if;
     106
     107      if  ncalls = 3 then
     108          call ltlsio(1);      $ terminate sio.
     109          end if;
     110
     111      while  1;  $ sysfin must not return.
     112          call sysfin(sflev, sfcod);
     113          end while;
     114      end subr ltlfin;
     115      subr usratp;
     116      $   null version of user abnormal termination procedure called if
     117      $abnormal termination.
     118      end subr usratp;
       1 .=member s37xtr1
       2 .+s37.
       3      $   macros for s37 error routines.
       4      +*  badaddr = 7nbadr$li **   $ function to check for bad address.
       5
       6      +*  addrp(n) = (.f. 1, 24, (n)) **   $ address value.
       7
       8
       9      subr ltlxtr1(saveloc, parm);  $ handle trace-back chain.
      10      $   this routine processes trace-back chains.  -saveloc- is set by
      11      $   an assembler routine to point to the address of the last save
      12      $   area.  -parm- is 1 to just scan the trace-back chain and save
      13      $   it in storage and 0 to print the trace-back chain.  if -parm-
      14      $   is zero and no trace-back chain has been saved, the current
      15      $   trace-back chain is listed.
      16      size  saveloc(ps);   $ location of highest save area.
      17      size  parm(1);       $ set to 1 to print chain.
      18      size  backptrs(ps);  data backptrs = 0;  $ number of back pointers
      19      size  addrs(ws);  dims  addrs(15);   $ calling addresses.
      20      size  rnames(.sds. 9);  dims rnames(9);   $ routine names.
      21      size  i(ps);   $ loop variable.
      22      size  curaddr(ps);  $ current save area address.
      23      size  entry(ps);   $ possible routine entry address.
      24      size  namelen(ps);  $ get name length.
      25      size  memget(ws);   $ function to get a word from memory.
      26      size  badaddr(1);   $ function to validity check an address.
      27
      28      +*  byte(n) =  $ fetch byte -n- from memory.
      29          (.f. 25 - (.f. 1, 2, (n))*8, 8, memget((n)/cpw)) **
      30
      31      $   check for a trace-back chain already set and go print it if so
      32      if  (backptrs) go to print;  $ go print chain.
      33
      34 /store/  $   here to store trace-back chain.
      35      $   now store chain in local storage.  first get initial save area
      36      $   pointer.
      37      curaddr = saveloc/cpw;  $ set to word address.
      38      do  backptrs = 1 to 15;  $ now process each save area.
      39          if  curaddr = 0 then  $ this is the end of the chain.
      40              addrs(backptrs) = 0;  $ flag it as such.
      41              quit do;  $ done with this loop.
      42
      43          elseif  badaddr(curaddr) then  $ check for bad save-area addre
      44              addrs(backptrs) = -1;  $ flag as bad address.
      45              quit do;  $ done with loop.
      46
      47          else    $   save area is valid - get calling address.
      48              addrs(backptrs) = addrp(memget(curaddr+3));   $ get r14.
      49              end if;
      50
      51          $   now see if can determine name of routine.
      52          entry = addrp(memget(curaddr+4));  $ get contents of r15.
      53          rnames(backptrs) = '';  $ set initially to null name.
      54          until  yes;  $ quit if -entry- is not routine entry point.
      55              if  (badaddr(entry/cpw)) quit until;  $ if invalid, not en
      56              if  (byte(entry) ^= 4b'47') quit until;  $ not branch.
      57              if  (byte(entry+1) ^= 4b'f0') quit until;
      58              if  (byte(entry+2) ^= 4b'f0') quit until;
      59              namelen = byte(entry+4);    $ get name length.
      60              if  (namelen > 30) quit until;  $ not valid if this long.
      61              if  (namelen > 9) namelen = 9;  $ set to max. we will prin
      62              rnames(backptrs) = '' .pad. 9;  $ set to all blanks.
      63              .len. rnames(backptrs) = namelen;  $ set length.
      64              do  i = 1 to namelen;  $ move in each character.
      65                  .ch. i, rnames(backptrs) = byte(entry+4+i);
      66                  end do;
      67              end until;
      68
      69          curaddr = addrp(memget(curaddr+1))/cpw;  $ next save area.
      70          end do;
      71
      72      $   now, if -parm- is one, we are done and should return.
      73      if  (parm) return;   $ done if just saving trace-back chain.
      74
      75 /print/  $   here to print trace-back chain.
      76      $   now print the trace-back information stored from above or from
      77      $   an earlier call.
      78      endl textl('   trace-back chain:') endl endl
      79
      80      do  i = 1 to backptrs;  $ scan all back pointers.
      81          if  addrs(i) <= 0 then   $ this is end of chain.
      82              if  addrs(i) < 0 then  $ this is an error.
      83                  textl(' **** invalid trace-back chain ****') endl
      84                  end if;
      85
      86              quit do;  $ done printing chain.
      87              end if;
      88
      89          if  .len. rnames(i) then   $ print routine name.
      90              textl('routine ''') textl(rnames(i)) textl(''' ')
      91              end if;
      92
      93          $   now print calling address.
      94          textl('called from ') addrl(addrs(i))
      95          if  (badaddr(addrs(i)/cpw)) textl(' (address invalid)')
      96          endl
      97          end do;
      98
      99      endl
     100      backptrs = 0;   $ show nothing saved to be printed.
     101
     102      $   now, if this was call to set trace-back chain, we must have ha
     103      $   had one in the buffers already and have just printed it so
     104      $   we must go back and set the current chain.  note that this
     105      $   will very often cause the set chain to be incorrect but it
     106      $   is more important to get the initial chain correct since
     107      $   it is the first error that the user is probably the most
     108      $   interested in
     109      if  (parm = 1) go to store;  $ go store trace-back chain.
     110
     111      end subr ltlxtr1;
       1 .=member s37errs
       2      subr ltlintr(psw, gpr);
       3      access exitns;   $ access termination nameset.
       4      $    this routine is entered when osint detects a program
       5      $    check.
       6      size  psw(2*ws);   $ program status word at interrupt
       7      size  gpr(ws); dims  gpr(16);  $ machine registers at interrupt
       8      size  inttyp(ps);  $ program check type
       9      size  intaddr(ps);   $ interrupt address
      10      size  badaddr(1);  $ checks for bad address.
      11
      12      size  pgmmsg(sds(20));   $ program check messages
      13      +*  numchecks = 19 **  $ number of program check types
      14      dims  pgmmsg(numchecks);
      15      data  pgmmsg = 'operation',
      16                     'priv. operation',
      17                     'execute',
      18                     'protection',
      19                     'addressing',
      20                     'specification',
      21                     'data',
      22                     'fixed overflow',
      23                     'fixed divide',
      24                     'decimal overflow',
      25                     'decimal divide',
      26                     'exponent overflow',
      27                     'exponent underflow',
      28                     'significance',
      29                     'floating divide',
      30                     'segment translation',
      31                     'page translation',
      32                     'trans. specification',
      33                     'special operation';
      34
      35
      36      if pgmckflg then  $ this is recursive
      37          call ltlfin(1, 4000);   $ exit quickly.
      38      else
      39          pgmckflg = yes;  $ show in program check routine
      40          call ltlxtrs;  $ set trace-back chain.
      41          inttyp = .f. 33, 16, psw;  $ set interrupt type
      42          intaddr = .f. 1, 24, psw;  $ set interrupt address
      43          endl endl textl(' program check type')
      44          intlp(inttyp, 3)   $ write header message
      45          if inttyp <= numchecks then  $ value is valid
      46              textl(' (') textl(pgmmsg(inttyp)) textl(' exception)')
      47              end if;
      48
      49          textl(' occurred at ') addrl(intaddr)
      50          if badaddr(intaddr/cpw) then  $ write additional message
      51              textl(' (psw address invalid)')
      52              end if;
      53
      54          endl
      55          call ltlregl(gpr);  $ now list registers at time of error
      56          psw = 0;  $ show prgram check processed
      57          pgmckflg = no;  $ show out of routine.
      58          call ltlfin(1, 2000+inttyp);   $ terminate program.
      59          end if;
      60
      61      end subr ltlintr;
      62      subr ltlovtm;  $ entered when time runs out
      63      call ltlfin(1, 3220);  $ abort program.
      64
      65      end subr ltlovtm;
      66      subr ltlsioer(n, fn, iddname);   $ print -sio- error message.
      67      access exitns;    $ access termination nameset.
      68      $   this routine is called by -sio- to print error messages.
      69      size  n(ws);        $ error number.
      70      size  fn(ps);       $ file number.
      71      size  iddname(.sds. 18);   $ ddname.
      72      size  ddname(.sds. 18);   $ copy of -iddname-.
      73      size  i(ps);     $ temporary.
      74
      75      size  erntab(ps);   dims erntab(40);  $ error number table.
      76
      77      data erntab  =
      78
      79          1, 2, 3, 3, 4, 4, 5, 5, 6, 6,
      80          7, 8, 4, 5, 4, 4, 3, 3, 9, 10,
      81          11, 12, 9, 9, 9, 9, 9, 9, 9, 11,
      82          13, 0, 8, 14, 12, 12, 14, 15, 15, 9;
      83
      84      if  sioerflg then  $ this is recursive.
      85          call ltlfin(1, 4001);  $ get out.
      86          end if;
      87
      88      sioerflg = yes;   $ now set flag to indicate possible recursion.
      89      call ltlxtrs;   $ set trace-back chain.
      90
      91      endl textl(' error') intl(n) textl(' on file')
      92      intl(fn) textl('.  ')   $ print header text.
      93
      94      if  n = 32 then  $ illegal file number.
      95          textl('illegal file number')
      96          go to ret;
      97
      98      elseif  n > 40 ! n < 1 then  $ bad error number.
      99          textl('invalid error number')
     100          go to ret;
     101
     102      else
     103          ddname = iddname;  $ copy input ddname parameter.
     104          do  i = 18 to 1 by -1;  $ scan down ddname.
     105              if  (.ch. i, ddname = 1r )  .len. ddname = i-1;  $ shorten
     106              end do;
     107
     108          if  .len. ddname then  $ name is known.
     109              textl('(ddname=''') textl(ddname) textl('''.)  ')
     110          else    $   ddname is not known.
dsi   73              textl('(ddname=unknown.)')
     112              end if;
     113
     114          go to e(erntab(n)) in 1 to 15;  $ select code.
     115          end if;
     116
     117      +*  er(n, msg) = /e(n)/  textl(msg) go to ret; **
     118
     119      er(1, 'invalid file name')
     120      er(2, 'missing dd card')
     121      er(3, 'physical i/o error')
     122      er(4, 'i/o sequence error')
     123      er(5, 'file cannot be opened')
     124      er(6, 'pds or tape already opened')
     125      er(7, 'insufficient memory')
     126      er(8, 'cannot close file')
     127      er(9, 'unexpected error')
     128      er(10, 'cannot rewind file')
     129      er(11, 'file not connected')
     130      er(12, 'bad record length on i/o operation')
     131      er(13, 'formatted/unformatted conflict')
     132      er(14, 'bad access code specified')
     133      er(15, 'bad unformatted block length')
     134
     135 /ret/
     136      textl('.') endl endl endl
     137
     138      sioerflg = no;   $ show error processing done.
     139
     140      call ltlfin(1, 2100+n);  $ terminate program.
     141
     142      end subr ltlsioer;
     143 ..s37
       1 .=member s47xtr1
       2 .+s47.
       3
       4 $    the first version of these procedures obtained by copying s37
       5 $    code. much of the traceback should be the same for s47, though
       6 $    need to review interface with c, i.e., caller of little main
       7 $    program.
       8 $    s47errs contains ltlintr which for s37 is called by procedure
       9 $    sysintr in little env (cms env assemble). some conversion to
      10 $    error codes and conventions used by uts is needed; for example,
      11 $    uts certainly doesn't have 'missing dd card' error, etc.
      12      $   macros for s47 error routines.
      13      +*  badaddr = 7nbadr$li **   $ function to check for bad address.
      14
      15      +*  addrp(n) = (.f. 1, 24, (n)) **   $ address value.
      16
      17
      18      subr ltlxtr1(saveloc, parm);  $ handle trace-back chain.
      19      $   this routine processes trace-back chains.  -saveloc- is set by
      20      $   an assembler routine to point to the address of the last save
      21      $   area.  -parm- is 1 to just scan the trace-back chain and save
      22      $   it in storage and 0 to print the trace-back chain.  if -parm-
      23      $   is zero and no trace-back chain has been saved, the current
      24      $   trace-back chain is listed.
      25      size  saveloc(ps);   $ location of highest save area.
      26      size  parm(1);       $ set to 1 to print chain.
      27      size  backptrs(ps);  data backptrs = 0;  $ number of back pointers
      28      size  addrs(ws);  dims  addrs(15);   $ calling addresses.
      29      size  rnames(.sds. 9);  dims rnames(9);   $ routine names.
      30      size  i(ps);   $ loop variable.
      31      size  curaddr(ps);  $ current save area address.
      32      size  entry(ps);   $ possible routine entry address.
      33      size  namelen(ps);  $ get name length.
      34      size  memget(ws);   $ function to get a word from memory.
      35      size  badaddr(1);   $ function to validity check an address.
      36
      37      +*  byte(n) =  $ fetch byte -n- from memory.
      38          (.f. 25 - (.f. 1, 2, (n))*8, 8, memget((n)/cpw)) **
      39
      40      $   check for a trace-back chain already set and go print it if so
      41      if  (backptrs) go to print;  $ go print chain.
      42
      43 /store/  $   here to store trace-back chain.
      44      $   now store chain in local storage.  first get initial save area
      45      $   pointer.
      46      curaddr = saveloc/cpw;  $ set to word address.
      47      do  backptrs = 1 to 15;  $ now process each save area.
      48          if  curaddr = 0 then  $ this is the end of the chain.
      49              addrs(backptrs) = 0;  $ flag it as such.
      50              quit do;  $ done with this loop.
      51
      52          elseif  badaddr(curaddr) then  $ check for bad save-area addre
      53              addrs(backptrs) = -1;  $ flag as bad address.
      54              quit do;  $ done with loop.
      55
      56          else    $   save area is valid - get calling address.
      57              addrs(backptrs) = addrp(memget(curaddr+3));   $ get r14.
      58              end if;
      59
      60          $   now see if can determine name of routine.
      61          entry = addrp(memget(curaddr+4));  $ get contents of r15.
      62          rnames(backptrs) = '';  $ set initially to null name.
      63          until  yes;  $ quit if -entry- is not routine entry point.
      64              if  (badaddr(entry/cpw)) quit until;  $ if invalid, not en
      65              if  (byte(entry) ^= 4b'47') quit until;  $ not branch.
      66              if  (byte(entry+1) ^= 4b'f0') quit until;
      67              if  (byte(entry+2) ^= 4b'f0') quit until;
      68              namelen = byte(entry+4);    $ get name length.
      69              if  (namelen > 30) quit until;  $ not valid if this long.
      70              if  (namelen > 9) namelen = 9;  $ set to max. we will prin
      71              rnames(backptrs) = '' .pad. 9;  $ set to all blanks.
      72              .len. rnames(backptrs) = namelen;  $ set length.
      73              do  i = 1 to namelen;  $ move in each character.
      74                  .ch. i, rnames(backptrs) = byte(entry+4+i);
      75                  end do;
      76              end until;
      77
      78          curaddr = addrp(memget(curaddr+1))/cpw;  $ next save area.
      79          end do;
      80
      81      $   now, if -parm- is one, we are done and should return.
      82      if  (parm) return;   $ done if just saving trace-back chain.
      83
      84 /print/  $   here to print trace-back chain.
      85      $   now print the trace-back information stored from above or from
      86      $   an earlier call.
      87      endl textl('   trace-back chain:') endl endl
      88
      89      do  i = 1 to backptrs;  $ scan all back pointers.
      90          if  addrs(i) <= 0 then   $ this is end of chain.
      91              if  addrs(i) < 0 then  $ this is an error.
      92                  textl(' **** invalid trace-back chain ****') endl
      93                  end if;
      94
      95              quit do;  $ done printing chain.
      96              end if;
      97
      98          if  .len. rnames(i) then   $ print routine name.
      99              textl('routine ''') textl(rnames(i)) textl(''' ')
     100              end if;
     101
     102          $   now print calling address.
     103          textl('called from ') addrl(addrs(i))
     104          if  (badaddr(addrs(i)/cpw)) textl(' (address invalid)')
     105          endl
     106          end do;
     107
     108      endl
     109      backptrs = 0;   $ show nothing saved to be printed.
     110
     111      $   now, if this was call to set trace-back chain, we must have ha
     112      $   had one in the buffers already and have just printed it so
     113      $   we must go back and set the current chain.  note that this
     114      $   will very often cause the set chain to be incorrect but it
     115      $   is more important to get the initial chain correct since
     116      $   it is the first error that the user is probably the most
     117      $   interested in
     118      if  (parm = 1) go to store;  $ go store trace-back chain.
     119
     120      end subr ltlxtr1;
       1 .=member s47errs
       2      subr ltlintr(psw, gpr);
       3      access exitns;   $ access termination nameset.
       4      $    this routine is entered when osint detects a program
       5      $    check.
       6      size  psw(2*ws);   $ program status word at interrupt
       7      size  gpr(ws); dims  gpr(16);  $ machine registers at interrupt
       8      size  inttyp(ps);  $ program check type
       9      size  intaddr(ps);   $ interrupt address
      10      size  badaddr(1);  $ checks for bad address.
      11
      12      size  pgmmsg(sds(20));   $ program check messages
      13      +*  numchecks = 19 **  $ number of program check types
      14      dims  pgmmsg(numchecks);
      15      data  pgmmsg = 'operation',
      16                     'priv. operation',
      17                     'execute',
      18                     'protection',
      19                     'addressing',
      20                     'specification',
      21                     'data',
      22                     'fixed overflow',
      23                     'fixed divide',
      24                     'decimal overflow',
      25                     'decimal divide',
      26                     'exponent overflow',
      27                     'exponent underflow',
      28                     'significance',
      29                     'floating divide',
      30                     'segment translation',
      31                     'page translation',
      32                     'trans. specification',
      33                     'special operation';
      34
      35
      36      if pgmckflg then  $ this is recursive
      37          call ltlfin(1, 4000);   $ exit quickly.
      38      else
      39          pgmckflg = yes;  $ show in program check routine
      40          call ltlxtrs;  $ set trace-back chain.
      41          inttyp = .f. 33, 16, psw;  $ set interrupt type
      42          intaddr = .f. 1, 24, psw;  $ set interrupt address
      43          endl endl textl(' program check type')
      44          intlp(inttyp, 3)   $ write header message
      45          if inttyp <= numchecks then  $ value is valid
      46              textl(' (') textl(pgmmsg(inttyp)) textl(' exception)')
      47              end if;
      48
      49          textl(' occurred at ') addrl(intaddr)
      50          if badaddr(intaddr/cpw) then  $ write additional message
      51              textl(' (psw address invalid)')
      52              end if;
      53
      54          endl
      55          call ltlregl(gpr);  $ now list registers at time of error
      56          psw = 0;  $ show prgram check processed
      57          pgmckflg = no;  $ show out of routine.
      58          call ltlfin(1, 2000+inttyp);   $ terminate program.
      59          end if;
      60
      61      end subr ltlintr;
      62      subr ltlovtm;  $ entered when time runs out
      63      call ltlfin(1, 3220);  $ abort program.
      64
      65      end subr ltlovtm;
      66      subr ltlsioer(n, fn, iddname);   $ print -sio- error message.
      67      access exitns;    $ access termination nameset.
      68      $   this routine is called by -sio- to print error messages.
      69      size  n(ws);        $ error number.
      70      size  fn(ps);       $ file number.
      71      size  iddname(.sds. 18);   $ ddname.
      72      size  ddname(.sds. 18);   $ copy of -iddname-.
      73      size  i(ps);     $ temporary.
      74
      75      size  erntab(ps);   dims erntab(40);  $ error number table.
      76
      77      data erntab  =
      78
      79          1, 2, 3, 3, 4, 4, 5, 5, 6, 6,
      80          7, 8, 4, 5, 4, 4, 3, 3, 9, 10,
      81          11, 12, 9, 9, 9, 9, 9, 9, 9, 11,
      82          13, 0, 8, 14, 12, 12, 14, 15, 15, 9;
      83
      84      if  sioerflg then  $ this is recursive.
      85          call ltlfin(1, 4001);  $ get out.
      86          end if;
      87
      88      sioerflg = yes;   $ now set flag to indicate possible recursion.
      89      call ltlxtrs;   $ set trace-back chain.
      90
      91      endl textl(' error') intl(n) textl(' on file')
      92      intl(fn) textl('.  ')   $ print header text.
      93
      94      if  n = 32 then  $ illegal file number.
      95          textl('illegal file number')
      96          go to ret;
      97
      98      elseif  n > 40 ! n < 1 then  $ bad error number.
      99          textl('invalid error number')
     100          go to ret;
     101
     102      else
     103          ddname = iddname;  $ copy input ddname parameter.
     104          do  i = 18 to 1 by -1;  $ scan down ddname.
     105              if  (.ch. i, ddname = 1r )  .len. ddname = i-1;  $ shorten
     106              end do;
     107
     108          if  .len. ddname then  $ name is known.
     109              textl('(ddname=''') textl(ddname) textl('''.)  ')
     110          else    $   ddname is not known.
     111              textl('(ddname=unknown.)')
     112              end if;
     113
     114          go to e(erntab(n)) in 1 to 15;  $ select code.
     115          end if;
     116
     117      +*  er(n, msg) = /e(n)/  textl(msg) go to ret; **
     118
     119      er(1, 'invalid file name')
     120      er(2, 'missing dd card')
     121      er(3, 'physical i/o error')
     122      er(4, 'i/o sequence error')
     123      er(5, 'file cannot be opened')
     124      er(6, 'pds or tape already opened')
     125      er(7, 'insufficient memory')
     126      er(8, 'cannot close file')
     127      er(9, 'unexpected error')
     128      er(10, 'cannot rewind file')
     129      er(11, 'file not connected')
     130      er(12, 'bad record length on i/o operation')
     131      er(13, 'formatted/unformatted conflict')
     132      er(14, 'bad access code specified')
     133      er(15, 'bad unformatted block length')
     134
     135 /ret/
     136      textl('.') endl endl endl
     137
     138      sioerflg = no;   $ show error processing done.
     139
     140      call ltlfin(1, 2100+n);  $ terminate program.
     141
     142      end subr ltlsioer;
     143 ..s47
       1 .=member failml
       2      subr 7nfal2$ml(enum,len, msg);  $ failure in math library.
       3      size  enum(ps);         $ error number.
       4      size  len(ps);          $ number of words in message.
       5      size  msg(ws);  dims msg(2);  $ message text.
       6      size  i(ps);            $ loop index.
       7      endl  textl('error number ')
       8      intl(enum) textl(' in mathematical library: ')
       9      do  i = 1 to len;  wordl(msg(i));  end do;
      10      endl
      11      call ltlfin(1, 1100+enum);  $ math library error.
      12      end subr;
       1 .=member begmon
       2 $    macro section for run time monitor aids procedures
       3      +*  subtabdim = 30 **  $ procedure stack limit
       4      +*  namelen = 15 ** $ length of significant part of name
       5      +*  subtabsiz = sds(namelen) **  $ length of subroutine stack
       6      +*  dbcursubn = dbsubtab(dbsubtabp) **  $ access top of stack
       7      +*  dbcurfsw = dbfswtab(dbsubtabp) **  $ access switch
       8
       9 $ to avoid conflicts with user procedures, the names of monitor procedu
      10 $ begin with a four character code followed by '$mp'.
      11
      12      +*  prst = 7nprst$mp **  $ print stores
      13      +*  prs3 = 7nprs3$mp **  $ print stores (3 parameters)
      14      +*  prs4 = 7nprs4$mp **  $ print stores (4 parameters)
      15      +*  prs5 = 7nprs5$mp **  $ print stores (5 parameters)
      16      +*  pren = 7npren$mp **  $ print entry
      17      +*  prex = 7nprex$mp **  $ print exit
      18      +*  prar = 7nprar$mp **  $ print argument
      19      +*  prfl = 7nprfl$mp **  $ print flow trace
      20      +*  trfl = 7ntrfl$mp **  $ trace flow
      21      +*  cinx = 7ncinx$mp **  $ check index on store
      22      +*  prhd = 7nprhd$mp **  $ print assert header
      23      +*  prvr = 7nprvr$mp **  $ print assert variable
      24      +*  asfl = 7nasfl$mp **  $ simple assertion failure
      25      +*  subn = 7nsubn$mp **  $ establish subprocedure name and type
      26      +*  subx = 7nsubx$mp **  $ show exit from procedure
      27      +*  setx = 7nsetx$mp **  $ set monitor parameters
      28      +*  cntu = 7ncntu$mp **  $ countup overflow
      29      +*  llex = 7nllex$mp **  $ monitor line limit exceeded
      30      +*  lhdr = 7nlhdr$mp **  $ print line header
      31      +*  varo = 7nvaro$mp **  $ output a variable
      32
      33 $ the names of namesets used by monitor are also protected.
      34
      35      +*  bugns = 7ndbgn$mp **  $ monitor nameset
      36      +*  flown  = 7nflwn$mp **  $ flow globals
      37      +*  storen = 7nstrn$mp **  $ store trace globals
      38      +*  entryn = 7nentn$mp **  $ entry trace globals
      39      +*  asertn = 7nastn$mp **  $ assert globals
      40
      41 $    macro -countup- increments ptr and checks for array overflow
      42      +*  countup(ptr, lim, msg) =
      43          ptr = ptr + 1;
      44          if  (ptr > lim) then
      45              call cntu(msg, lim);  $ call error procedure
      46              return;
      47              end if; **
      48
      49 $    macro -endld- calls endl and increments line count to check for
      50 $    line limit overflow.
      51      +*  endld = endl
      52          dblinect = dblinect + 1;
      53          if  dblinect > dblinelim & dblinelim > 0  then
      54              call llex;  $ call error procedure
      55              return;
      56              end if;
      57          **
      58
      59      +*  newlin =  $ this macro begins a new line
      60          if  pfcol > 2 then  endld  end if;  $ start new line if needed
      61          **
      62
      63      +*  monitorhead(line, type) =  $ print header - line is line no.
      64 $ type is 1 for 'entry', 2 for 'exit', 3 for 'store', and 4 for 'error'
      65          call lhdr(line, type);  $ print header
      66          **
      67
      68      +*  monitorvarout(name, flag, index, nwds, val) =
      69 $ this macro is used to print a value.  -name- is the name of the
      70 $ variable being printed, -nwds- is the number of words in the
      71 $ variable, -val- is the value, -flag- is non-zero if the variable
      72 $ is indexed, in which case -index- is the index.
      73          call varo(name, flag, index, nwds, val);  $ output variable
      74          **
      75
      76 $    dimensions of arrays
      77      +*  flowtabdim = 200 **  $ table for flow trace counters
      78      +*  flroutsdim = 40 **   $ table for flow trace - ptrs to flowtab
      79      +*  labtabdim = 40 **    $ table for flow trace - label table
      80
      81 $    fields of flow table
      82      $   fid is the id of the code block.  fftyp is a subfield of
      83      $   giving gross type.  ffblock is unique identification number.
      84      $   fdone is flag for when entry done.  flino is line number.
      85      $   flabnam is label name pointer.  fcount is executions counter.
      86
      87 .+s10.
      88      +*  fid      = .f. 01, 18, **
      89      +*  fftyp    = .f. 01, 03, **
      90      +*  ffblock  = .f. 04, 15, **
      91      +*  flabnam  = .f. 19, 18, **
      92      +*  fdone    = .f. 37, 01, **
      93      +*  flino    = .f. 38, 17, **
      94      +*  fcount   = .f. 55, 18, **
      95 ..s10
      96 .+s11.
      97      +*  fid      = .f. 01, 16, **
      98      +*  fftyp    = .f. 01, 03, **
      99      +*  ffblock  = .f. 04, 13, **
     100      +*  flabnam  = .f. 17, 16, **
     101      +*  fdone    = .f. 33, 01, **
     102      +*  flino    = .f. 34, 15, **
     103      +*  fcount   = .f. 49, 16, **
     104 ..s11
vax   36 .+s32.
vax   37      +*  fid      = .f. 01, 16, **
vax   38      +*  fftyp    = .f. 01, 03, **
vax   39      +*  ffblock  = .f. 04, 13, **
vax   40      +*  flabnam  = .f. 17, 16, **
vax   41      +*  fdone    = .f. 33,  1, **
vax   42      +*  flino    = .f. 34, 15, **
vax   43      +*  fcount   = .f. 49, 16, **
vax   44 ..s32
     114 .+s37.
     115      +*  fid      = .f. 01, 16, **
     116      +*  fftyp    = .f. 01, 03, **
     117      +*  ffblock  = .f. 04, 13, **
     118      +*  flabnam  = .f. 17, 16, **
     119      +*  fdone    = .f. 33,  1, **
     120      +*  flino    = .f. 34, 15, **
     121      +*  fcount   = .f. 49, 16, **
     122 ..s37
utsa  98 .+s47.
utsa  99      +*  fid      = .f. 01, 16, **
utsa 100      +*  fftyp    = .f. 01, 03, **
utsa 101      +*  ffblock  = .f. 04, 13, **
utsa 102      +*  flabnam  = .f. 17, 16, **
utsa 103      +*  fdone    = .f. 33,  1, **
utsa 104      +*  flino    = .f. 34, 15, **
utsa 105      +*  fcount   = .f. 49, 16, **
utsa 106 ..s47
dsw   15 .+s40.
dsw   16      +*  fid      = .f. 01, 16, **
dsw   17      +*  fftyp    = .f. 01, 03, **
dsw   18      +*  ffblock  = .f. 04, 13, **
dsw   19      +*  flabnam  = .f. 17, 16, **
dsw   20      +*  fdone    = .f. 33, 01, **
dsw   21      +*  flino    = .f. 34, 15, **
dsw   22      +*  fcount   = .f. 49, 16, **
dsw   23 ..s40
     123 .+s66.
     124      +*  fid      = .f. 01, 13, **
     125      +*  fftyp    = .f. 01, 03, **
     126      +*  ffblock  = .f. 04, 10, **
     127      +*  fdone    = .f. 14, 01, **
     128      +*  flino    = .f. 17, 16, **
     129      +*  flabnam  = .f. 33, 07, **
     130      +*  fcount   = .f. 40, 17, **
     131 ..s66
     132
     133 $    fields for flowrouts
     134      +*  fbeg = .f. 1, 8, ** $ ptr to flowtab - beginning of procedure
     135      +*  lbeg = .f. 9, 8, ** $ ptr to labtab - beginning of procedure
     136
     137 $ sizes of monitor tables
     138
     139      +*  labtabsiz = sds(namelen) **  $ length of label table
     140      +*  flroutssiz = ws **  $ can fit in word for all machines
     141      +*  flowtabsiz =   $ size of flow table
     142 .+s10    2*ws
     143 .+s11    4*ws
vax   45 .+s32    2*ws
     145 .+s37    2*ws
utsa 107 .+s47    2*ws
dsw   24 .+s40    4*ws
     146 .+s66    ws
     147          **
     148
     149      +*  dbgwordsz =  $ size of 'word' passed as descriptor
     150 .+s10    ws
     151 .+s11    2*ws
vax   46 .+s32    ws
     153 .+s37    ws
utsa 108 .+s47    ws
dsw   25 .+s40    2*ws
     154 .+s66    ws
     155          **
     156
       1 .=member subn
       2      subr subn(name, fsw);
       3      $   this procedure sets the global values for subroutine name
       4      $   and switch at the start of a procedure.
dsx   13      nameset bugns;
dsx   14 $    globals for monitor package
dsx   15      size  dbbytefg(1); data dbbytefg = no;  $ set to print bit in all
dsx   16      size  dbsubtab(subtabsiz); dims dbsubtab(subtabdim);  $ procedure
dsx   17      size  dbfswtab(ps);  dims dbfswtab(subtabdim);  $ switch value tab
dsx   18      size  dbsubtabp(ps); data dbsubtabp = 0;  $ pointer to -dbsubtab-
dsx   19      size  dbnewsubfg(1);  $ 'new subroutine' flag
dsx   20      end nameset bugns;
dsx   21      access lcpns;
       6      size  name(subtabsiz);     $ procedure name
       7      size  fsw(ps);  $ funct/subr/prog switch.
dsx   22      size  i(ps);            $ name length.
       8
dsx   23      i = namelen;
dsx   24      if  (slen name <= namelen)  i = slen name;
dsz    8      $   accept null string as argument, and treat this as request
dsz    9      $   to reset dbsubtabp, as special service to setl system.
dsz   10      if  i = 0  then  $ if reset request.
dsz   11          dbsubtabp = 0;
dsz   12          return;
dsz   13          end if;
dsz   14      countup(dbsubtabp, subtabdim, 'dsubtab');
dsx   25      dbcursubn = .s. 1, i, name;  $ extract part
      15      dbcurfsw = fsw;  $ set fnct/subr flag
      16      dbnewsubfg = yes;  $ set flag for flow trace
      17      end subr subn;
       1 .=member subx
       2      subr subx;
       3      access lcpns,bugns;;
       4      $   this procedure pops the subroutine stack
       5
       6      if  (dbsubtabp = 0) return;  $ error
       7      dbsubtabp = dbsubtabp-1;  $ pop stack
       8      end subr subx;
       1 .=member lhdr
       2      subr lhdr(line, type);  $ print monitor header
dsx   26      access bugns, lcpns;
      12      size  line(ps);  $ line number
      13      size  type(ps);  $ type: 1=entry, 2=exit, 3=store, 4=error
      14      size  dbfswtxt(.sds. 5);  dims dbfswtxt(3);  $ name of proc type.
      15      data  dbfswtxt = 'subr ', 'fnct ', 'prog ';
      16
      17      newlin;  $ start new line
      18      dblinenum = dblinenum+1;  $ count line
      19      if  dblinenum = 10 then  $ must skip a line
      20          dblinenum = 0;  $ reset
      21          endld  $ leave blank line
      22          end if;
      23      tabl(dbsubtabp*4-2) textl('--> ')  $ indent
      24      if  type = 1 then
      25          textl('entry ')
      26      elseif  type = 2 then
      27          textl('exit  ')
      28      elseif  type = 3 then
      29          textl('store ')
      30      else
      31          textl('error ')
      32          end if;
      33      textl('at line ') intl(line) textl(' in ')
      34      textl(dbfswtxt(dbcurfsw+1))
      35      textl(dbcursubn)
      36      if  (type > 2) textl(': ')
      37
      38      end subr lhdr;
       1 .=member trfl
       2      subr trfl(word, label);
       3      $   procedure which counts number of times labeled blocks of code
       4      $   are executed.
       5      access lcpns,bugns;
       6      size  word(dbgwordsz);  $ parameter 'word'
       7      +*  flowid = .f. 1, 13, **  $ block id
       8      +*  flowtyp = .f. 1, 3, **  $ block type
       9      +*  while_type = 1 **  $ type of 'while' statement
      10      +*  until_type = 2 **  $ type of 'until' statement
      11      +*  do_type    = 3 **  $ type of 'do' statement
      12      +*  iftru_type = 4 **  $ 'if' - true
      13      +*  iffls_type = 5 **  $ 'if' - false
      14      +*  label_type = 6 **  $ label
      15      +*  flowblock = .f. 4, 10, **  $ block no.
      16      +*  flowlino  = .f. 17, 16, ** $ line no.
      17      size  label(ws+1);  $ label
      18      size  fent(flowtabsiz);          $ flowtab entry
      19      size  i(ps);             $ do loop var
      20      size  flowtabb(ps);      $ bottom ptr to start of procedure
      21
      22      nameset flown;      $ nameset for flow trace
      23      size  flowfg(1);    data  flowfg = 1;         $ flow flag
      24      size  flowtab(flowtabsiz);  dims  flowtab(flowtabdim); $ table for
      25      size  flrouts(flroutssiz); dims  flrouts(flroutsdim); $ procedures
      26      size  flowlab(labtabsiz); dims  flowlab(labtabdim);    $ label nam
      27      size  flowtabp(ps); data  flowtabp = 0;       $ ptr to flowtab
      28      size  flroutsp(ps); data  flroutsp = 0;       $ ptr to flrouts
      29      size  flowlabp(ps); data  flowlabp = 0;         $ ptr to flowlab
      30      end nameset flown;
      31
      32      if  (dbstoplist) return;   $ excede line limit
      33      if  (flowfg = no) return; $ dynamic flag not on
      34      if  (flroutsp = 0) go to newrout;
      35      if  (dbnewsubfg) go to newrout;
      36 $    in same procedure. search for entry in flowtab. if none exist,
      37 $    start new entry.
      38      flowtabb = fbeg flrouts(flroutsp);    $ beginning of procedure
      39      do  i = flowtabb to flowtabp;
      40          if  (flowid word ^= fid flowtab(i)) cont do ;
      41      $ found block
      42          fcount flowtab(i) = fcount flowtab(i) + 1;
      43          return;
      44          end do;
      45      $   block not found - add new entry to flowtab
      46      go to addlab;
      47
      48 /newrout/          $ entered new procedure
      49      dbnewsubfg = no;
      50      countup(flroutsp, flroutsdim, 'flrouts');
      51      fbeg flrouts(flroutsp) = flowtabp + 1;  $ beg of rout in flowtab
      52      lbeg flrouts(flroutsp) = flowlabp + 1; $ beg of rout in flowlab
      53 /addlab/ $ add new entry to flowtab and flowlab if applicable
      54      countup(flowtabp, flowtabdim, 'flowtab');
      55      fent = 0;  $ clear entry
      56      fid fent = flowid word;
      57      flino fent = flowlino word;
      58      if  flowtyp word = label_type then
      59          countup(flowlabp, labtabdim, 'flowlab')
      60          flabnam fent = flowlabp;       $ ptr to label name
      61          if  slen label <= namelen then
      62              flowlab(flowlabp) = label;  $ just copy
      63          else
      64              flowlab(flowlabp) = .s. 1, namelen, label;  $ else extract
      65              end if;
      66          end if;
      67      fcount fent = 1;
      68      flowtab(flowtabp ) = fent;
      69      end subr trfl;
       1 .=member prfl
       2      subr prfl;
       3      $   procedure to print flow statistic at exit from procedure
       4      access lcpns,bugns;
       5      size  fent(flowtabsiz);          $ entry in flowtab
       6      size  i(ps);   $ do loop variables
       7      size  j(ps);
       8      access flown;
       9
      10      if  (dbstoplist) return;   $ excede line limit
      11      if  (flroutsp = 0) return;
      12      if  (dbnewsubfg) return;  $ nothing traced
      13      if  (flowfg = no) return;
      14      newlin; endld textl('*** flow trace for ')
      15      if  dbcurfsw then  textl('fnct ') else  textl('subr ') end if;
      16      textl(dbcursubn) textl(' ***') endld
      17      textl('codeblock   line   executions') endld  $ header
      18      do  i = fbeg flrouts(flroutsp) to flowtabp;
      19          fent = flowtab(i);
      20          go to l(fftyp fent) in while_type to label_type;
      21 /l(while_type)/  textl('while') go to rest;
      22 /l(until_type)/  textl('until') go to rest;
      23 /l(do_type)/    textl('do') go to rest;
      24 /l(label_type)/  charl(1r/) textl(flowlab(flabnam fent))  charl(1r/)
      25 /rest/   tabl(namelen+3) intl(flino fent) skipl(12)
      26          intl(fcount fent) endld
      27          cont do i;          $ go to next item
      28 /l(iftru_type)/  $ number of times a condition is true
      29      textl('if') tabl(namelen+3) intl(flino fent)  skipl(5)
      30      textl('true:  ') intl(fcount fent)
      31          do  j = i + 1 to flowtabp;  $ search for a matching false if
      32      if  (ffblock flowtab(j) ^= ffblock fent) cont do j;
      33      $ found a match
      34          textl('    false: ')   intl(fcount flowtab(j))
      35          fdone flowtab(j) = 1;         $ flag entry as done
      36          quit do  j;
      37          end do j;
      38          endld
      39      cont do i;
      40 /l(iffls_type)/ $ number of times a condition was false
      41      if  (fdone fent) cont do i;
      42      textl('if') tabl(namelen+3) intl(flino fent)  skipl(5)
      43      textl('false: ')  intl(fcount fent) endld
      44      end do i;
      45      textl('*********************************') endld endld
      46      $   update tables by popping top procedure from stacks
      47      flowtabp = fbeg flrouts(flroutsp) - 1;
      48      flowlabp = lbeg flrouts(flroutsp) - 1;
      49      flroutsp = flroutsp - 1;
      50      end subr prfl;
       1 .=member prst
       2      subr prst(varn, word, val, par1, par2, par3);
       3      access lcpns,bugns;
       4      size  varn(ws+1);   $ variable name
       5      size  word(dbgwordsz);  $ parameter 'word'
       6      +*  vsize  = .f. 01, 08, **  $ no. of words in var
       7      +*  vopcod = .f. 09, 03, **  $ store type
       8      +*  simp_type = 1 **  $ simple assignment
       9      +*  f_type    = 2 **  $ .f. assignment
      10      +*  e_type    = 3 **  $ .e. assignment
      11      +*  s_type    = 4 **  $ .s. assignment
      12      +*  ch_type   = 5 **  $ .ch. assignment
      13      +*  len_type  = 6 **  $ .len. assignment
      14      +*  vindx  = .f. 12, 01, **  $ flag for indexed assignment
      15      +*  vlino  = .f. 17, 16, **  $ line no.
      16      size  val(ws+1);   $ value to be listed
      17      size  par1(ps), par2(ps), par3(ps);  $ these are parameters
      18 $ for index, first bit, and length.  if any of these if not
      19 $ applicable it is skipped. i.e., in most cases at least one
      20 $ of these variables is undefined.
      21
      22      size  fbit(ps);  $ first bit position
      23      size  flen(ps);  $ field length
      24      size  nwd(ps);           $ number of words of target
      25      size  vcod(ps);          $ type of store
      26      size  fexts(sds(6));  dims  fexts(len_type);
      27      size  i(ps);             $ do loop var
      28      data   $ define values for store types
      29          fexts(simp_type) = ' ':         fexts(f_type)    = '.f.':
      30          fexts(e_type)    = '.e.':       fexts(s_type)    = '.s.':
      31          fexts(ch_type)   = '.ch.':      fexts(len_type)  = '.len. ';
      32
      33      nameset storen;     $ nameset for store trace
      34      size  storfg(1);  data  storfg = 1;   $ store flag
      35      end nameset storen;
      36
      37      if  (dbstoplist) return;  $ line limit exceded
      38      if  (storfg = no) return;
      39      $ print trace
      40      monitorhead(vlino word, 3);  $ print header info
      41      vcod = vopcod word;
      42      nwd = vsize  word;
      43      textl(fexts(vcod))  $ print type of store
      44      go to l(vcod) in simp_type to len_type;  $ select type
      45
      46 /l(simp_type)/    /l(len_type)/  $ simple store or .len.
      47      monitorvarout(varn, vindx word, par1, nwd, val); endld  $ print va
      48      return;
      49
      50 /l(f_type)/     /l(e_type)/  $ .f. or .e.
      51      if  vindx word then  $ var. is indexed
      52          fbit = par2; flen = par3;  $ set values
      53      else
      54          fbit = par1; flen = par2;  $ set values for non-indexed
      55          end if;
      56      intl(fbit) charl(1r,) intl(flen) textl(', ')  $ write positions
      57      monitorvarout(varn, vindx word, par1,
      58          (flen+ws-1)/ws, (.e. 1, flen, val)); endld  $ output value
      59      return;
      60
      61 /l(s_type)/  $ .s. assignment
      62      if  vindx word then  $ indexed
      63          fbit = par2; flen = par3;  $ get positions
      64      else
      65          fbit = par1; flen = par2;  $ get positions if not indexed
      66          end if;
      67      intl(fbit) charl(1r,) intl(flen) textl(', ')
      68      monitorvarout(varn, vindx word, par1, vsize word, val); endld
      69      return;
      70
      71 /l(ch_type)/    $ .ch. type
      72      if  vindx word then  fbit = par2;  else  fbit = par1; end if;
      73      intl(fbit) textl(', ') textl(varn)  $ start line
      74      if  vindx word then  charl(1r() intl(par1) charl(1r)) end if;
      75      textl(' = 1r') charl(val)
      76      if  dbbytefg then  $ byte value wanted
      77          textl(' = ') intlp(mradix, 1) textl('b''') bwordl(val)
      78          charl(1r')
      79          end if;
      80      endld
      81      end subr prst;
      82      subr prs3(varn, word, val);  $ print stores (3 parms)
      83      size  varn(ws+1), word(dbgwordsz), val(ws+1);
      84      call prst(varn, word, val, 0, 0, 0);
      85      end subr prs3;
      86      subr prs4(varn, word, val, p1);  $ print stores (4 parms)
      87      size  varn(ws+1), word(dbgwordsz), val(ws+1), p1(ps);
      88      call prst(varn, word, val, p1, 0, 0);
      89      end subr prs4;
      90      subr  prs5(varn, word, val, p1, p2);  $ print stores (5 parms)
      91      size  varn(ws+1), word(dbgwordsz), val(ws+1), p1(ps), p2(ps);
      92      call prst(varn, word, val, p1, p2, 0);
      93      end subr prs5;
       1 .=member pren
       2      subr pren;
       3      $ prints trace of entry to procedures if entry flag is on.
       4
       5      access lcpns,bugns;
       6      nameset entryn;
       7      size  entrfg(1); data  entrfg = 1;  $ entry flag
       8      end nameset entryn;
       9
      10      if  (dbstoplist) return;   $ excede line limit
      11      if  (entrfg = no) return;
      12      monitorhead(1, 1);  endld
      13      end subr pren;
       1 .=member prex
       2      subr prex(lineno, nwds, val);
       3      $   prints trace of exit from functions
       4      access lcpns,bugns;
       5      size  lineno(ps);  $ line no.
       6      size  nwds(ps);    $ no. of words of return value (if present)
       7      size  val(ws+1);   $ return value
       8      access entryn;
       9
      10      if  (dbstoplist) return;   $ excede line limit
      11      if  (entrfg = no) return;  $ runtime flag check
      12      monitorhead(lineno, 2);
      13      if  dbcurfsw = 1 then  $ this is a function.
      14          textl(' with ') monitorvarout(dbcursubn, no, 0, nwds, val);
      15          end if;
      16      endld
      17      end subr prex;
       1 .=member prar
       2      subr prar(varn, nwds, val);
       3      access lcpns,bugns;
       4      size  varn(ws+1);    $ variable name
       5      size  nwds(ps);      $ no. of words in value
       6      size  val(ws+1);     $ value of variable
       7      size  i(ps);   $ do loop index
       8      access entryn;
       9
      10      if  (dbstoplist) return;   $ excede line limit
      11      if  (entrfg = 0) return;
      12      monitorhead(1, 1);  $ say at line 1
      13      textl(' with ') monitorvarout(varn, no, 0, nwds, val); endld
      14      end subr prar;
       1 .=member cinx
       2      subr cinx(varn, val, dim, lineno);
       3 $    this procedure checks the range of an indexed store to make sure
       4 $    that no word outside the array boundary is being clobbered.
       5 $    if the check fails, the program aborts.
       6      access lcpns,bugns;;
       7      size  varn(ws+1);    $ variable name
       8      size  val(ws);       $ subscript value
       9      size  dim(ps);       $ array dimension
      10      size  lineno(ps);   $ line no.
      11
      12      if  (val <= dim) & (val > 0) return;
      13 $    print error message and abort
      14      monitorhead(lineno, 4);
      15      textl('*** index out of range.  array = ') textl(varn)
      16      tintl(' value of index', val) textl(' ***') endld
      17      call ltlfin(1, 1005);  $ $ array index out of range..
      18      end subr cinx;
       1 .=member prhd
       2      subr prhd(lineno);
       3      $ prints header of assertion list. streamlines output
       4      access lcpns,bugns;
       5      size  lineno(ps);  $ line no.
       6      nameset asertn;
       7      size  assertno(ps);  $ line no. of last assert failure
       8      end nameset;
       9
      10      if  (dbstoplist) return;   $ excede line limit
      11      assertno = lineno;  $ set line no.
dsi   74      monitorhead(lineno, 4); textl('*** assertion failed ***') endld
      13      end subr prhd;
       1 .=member prvr
       2      subr prvr(varn, nwds, val);
       3      $ prints values of variables in assertion statement
       4      access lcpns,bugns;
       5      size  varn(ws+1);   $ variable name
       6      size  nwds(ps);     $ number of words
       7      size  val(ws+1);    $ value of variable
       8      access asertn;
       9
      10      if  (dbstoplist) return;   $ excede line limit
      11      monitorhead(assertno, 4); monitorvarout(varn, no, 0, nwds, val);
      12      endld
      13      end subr prvr;
       1 .=member asfl
       2      subr asfl;
       3      $   print simple message for assertion faliure
       4
       5      endl textl('******** assertion failed ********') endl
       6      call ltlfin(1, 1006);  $ assertion failure.
       7      end subr asfl;
       1 .=member setx
       2      subr setx(parm, change);
       3      $   this procedure sets dynamic parameters
       4
       5      $   fields of -parm- and -change-
dsw   26      +*  slct  = .f.    1, ws-4, **  $ line limit
dsw   27      +*  spbit = .f. ws-3,  1, **  $ 'print byte'
dsw   28      +*  sflow = .f. ws-2,  1, **  $ 'set flow'
dsx   27      +*  sstor = .f. ws-1,  1, **  $ 'set store'
dsw   30      +*  sentr = .f. ws,  1, **  $ 'set entry'
      11      access lcpns,bugns;
dsw   31      size  parm(ws), change(ws);  $ parameters
      13      +*  mod(val, fld) =   if  (fld change) val = fld parm **
      14      access flown, storen, entryn;  $ access namesets
      15
      16      mod(dblinelim, slct);   mod(dbbytefg, spbit);
      17      mod(flowfg,    sflow);  mod(storfg,   sstor);
      18      mod(entrfg,    sentr);
      19      macdrop(mod)
      20
      21      end subr setx;
       1 .=member cntu
       2      subr cntu(msg, lim);  $ print countup overflow message
       3      access lcpns,bugns;;
       4      size  msg(ws+1);   $ message
       5      size  lim(ps);     $ array limit
       6
       7      textl('***** monitor array ') textl(msg)
       8      textl(' overflowed: limit is') intl(lim)
       9      textl('.  some monitor data lost *****') endld
      10      end subr cntu;
       1 .=member llex
       2      subr llex;  $ print monitor line limit exceeded
       3      access lcpns,bugns;;
       4
       5      textl('***** monitor line limit of ') intl(dblinelim)
       6      textl(' exceeded.  further monitor output suppressed *****') endl
       7      dbstoplist = yes;  $ set flag to stop further output
       8      end subr llex;
       1 .=member varo
       2      subr varo(name, flag, index, nwds, val);  $ output variable - debu
       3      access lcpns,bugns;;
       4      size  name(ws+1);  $ variable name
       5      size  flag(1);     $ set if variable is indexed
       6      size  index(ps);   $ index if it is
       7      size  nwds(ps);    $ number of words in vaariable
       8      size  val(ws+1);   $ value of variable
       9      size  i(ps);  $ define do loop variable
      10      size  flg(1);  $ set if byte val must be printed
      11
      12      if  (dbstoplist) return;
      13      textl(name)  $ output variable name
      14      if  flag then  $ var. is indexed
      15          charl(1r() intl(index) charl(1r))  $ print subscript
      16          end if;
      17      flg = yes;  $ show should print bit value
      18      if  nwds = 1 then  $ see if should print as integer
      19          if  .fb. .f.1, ws, val <= 16 !
      20              .fb. (-(.f. 1, ws, val)) <= 11 then
      21 $            value will fit in five digits printed by -intl-
      22              textl(' = ') intl(val)
      23              flg = no;  $ need not print
      24              end if;
      25          end if;
      26      if  sorg val > cs & nwds*ws >= (sorg val)-1 then  $ maybe sds
      27          if  ((sorg val)-1)/cs*cs = (sorg val)-1 &
      28              sds(slen val) <= sorg val then  $ if it is, it is well
      29              if  pfcol > pflen-(slen val)-5 then $ too long
      30                  endld tabl(10)  $ start new line
      31                  end if;
      32              textl(' = ''') textl(val) charl(1r')
      33              flg = no;
      34              end if;
      35          end if;
      36      if  flg ! dbbytefg then  $ print bit value
      37          textl(' = ') intlp(mradix, 1) textl('b''')
      38          do  i = nwds to 2 by -1;  $ print each word except last
      39              if  pfcol > pflen-bwordlen-5 then  $ line too long
      40                  endld tabl(10)
      41                  end if;
      42              bwordl(wordi(i, val))  charl(1r )
      43              end do;
      44          bwordl(wordi(1, val))  $ print last word
      45          charl(1r')
      46          end if;
      47
      48      end subr varo;
       1 .=member endmon
       1 .=member beglio
dsv  145      $   ifsa and ofsa are suggested optimizations that move
dsv  146      $   data directly from line buffer to user area where possible,
dsv  147      $   avoiding use of -gcb-.
dsv  148
dsv  149 .+s10.
dsv  150 .+set  ifsa_env
dsv  151 .+set  ofsa_env
dsv  152 .+set  prfi   $ set for debugging
dsv  153 ..s10
vaxa  11 .+s32.
vaxa  12 .+set ifsa_env
vaxa  13 .+set ofsa_env
dsb   49 .+set pcsa_env
vaxa  14 ..s32
vax   47 .+s37.
vax   48 .+set ifsa_env
vax   49 .+set ofsa_env
vax   50 ..s37
utsa 109 .+s47.
utsa 110 $ improved ifsa and ofsa not available (yet) for s47.
utsa 111 .-set ifsa_env
utsa 112 .-set ofsa_env
utsa 113 ..s47
       2 .+s66.
       3 .+set  ofsa_env,ifsa_env
       4 ..s66
dsf   74
utsb  33 .+s32u.
dsf   76 $ delete special env code for unix checkout.
dsf   77 .-set ifsa_env
dsf   78 .-set ofsa_env
dsf   79 .-set pcsa_env
utsb  34 ..s32u
dsf   81
utsa 114 .+s47.
utsa 115 $ delete special env code for unix checkout.
utsa 116 .-set ifsa_env
utsa 117 .-set ofsa_env
utsa 118 .-set pcsa_env
utsa 119 ..s47
utsa 120
       5      $   fields of io status area.
       6      $   title    - characters of external name.
       7      $   donotbit   - 'should we ignore this io request.'
       8      $   sfbit      - 'has streaming been forced.'
       9      $   ignorev    - current 'ignore' value.
      10      $   accessv    - current 'access' value.
      11      $   endseenv      - used for 'mark' in 'filestat'.
      12      $   errorv     - associated with 'error' in 'filestat'.
      13      $   binaryv      - 'is this binary file'.
      14      $   linesizev  - 'linesize' value.
      15      $   lbptr      - current position in line buffer.
      16      $   writing    - 'are we writing to file' (0 if reading)
      17      $   endack     - 'must user acknowledge end of file.'
      18      $   strorgv    - address of lsw of string for access string.
      19      $   lbmax      - if lbptr decremented while forming line then
      20      $                is largest value of lbptr, else is zero.
      21      $   linenum    - line number (number of sio ops)
      22
      23      +*  donotbit(f)  = .f.  01, 01, fatra(f) **
      24      +*  sfbit(f)     = .f.  02, 01, fatra(f) **
      25      +*  ignorev(f)   = .f.  04, 02, fatra(f) **
      26      +*  endack(f)    = .f.  06, 01, fatra(f) **
      27      +*  accessv(f)   = .f.  07, 03, fatra(f) **
      28      +*  endseenv(f)  = .f.  10, 01, fatra(f) **
      29      +*  canput(f)    = .f.  11, 01, fatra(f) **
      30      +*  canget(f)    = .f.  12, 01, fatra(f) **
      31      +*  writing(f)   = .f.  13, 01, fatra(f) **
      32      +*  errorv(f)    = .f.  17, 05, fatra(f) **
      33      +*  binaryv(f)   = .f.  22, 01, fatra(f) **
      34      +*  linesizev(f) = .f.  25, 08, fatra(f) **
      35 .+s10.
      36      +*  lbptr(f)     = .f. 37, 18, fatra(f) **
      37      +*  strorgv(f)   = .f. 55, 18, fatra(f) **
      38      +*  lbmax(f)     = .f. 73, 18, fatra(f) **
      39      +*  linenum(f)   = .f. 91, 18, fatra(f) **
      40 ..s10
      41 .+s11.
      42      +*  strorgv(f)   = .f. 33, 16, fatra(f) **
      43      +*  lbptr(f)     = .f. 49, 08, fatra(f) **
      44      +*  lbmax(f)     = .f. 57, 08, fatra(f) **
      45      +*  linenum(f)   = .f. 65, 16, fatra(f) **
      46 ..s11
vax   51 .+s32.
vax   52      +*  strorgv(f)   = .f. 33, 24, fatra(f) **
vax   53      +*  lbptr(f)     = .f. 57, 08, fatra(f) **
vax   54      +*  lbmax(f)     = .f. 65, 08, fatra(f) **
vax   55      $   for s32 redefine ignorev, accessv and errorv to
vax   56      $   improve code efficiency.
vax   57      +*  ignorev(f)   = .f. 73, 08, fatra(f) **
vax   58      +*  accessv(f)   = .f. 81, 08, fatra(f) **
vax   59      +*  errorv(f)    = .f. 89, 08, fatra(f) **
vax   60      +*  linenum(f)   = .f. 97, 24, fatra(f) **
vax   61 ..s32
      53 .+s37.
      54      +*  strorgv(f)   = .f. 33, 24, fatra(f) **
      55      +*  lbptr(f)     = .f. 57, 08, fatra(f) **
      56      +*  lbmax(f)     = .f. 65, 08, fatra(f) **
      57      $   for s37 redefine ignorev, accessv and errorv to
      58      $   improve code efficiency.
      59      +*  ignorev(f)   = .f. 73, 08, fatra(f) **
      60      +*  accessv(f)   = .f. 81, 08, fatra(f) **
      61      +*  errorv(f)    = .f. 89, 08, fatra(f) **
      62      +*  linenum(f)   = .f. 97, 24, fatra(f) **
      63 ..s37
utsa 121 .+s47.
utsa 122      +*  strorgv(f)   = .f. 33, 24, fatra(f) **
utsa 123      +*  lbptr(f)     = .f. 57, 08, fatra(f) **
utsa 124      +*  lbmax(f)     = .f. 65, 08, fatra(f) **
utsa 125      $   for s47 redefine ignorev, accessv and errorv to
utsa 126      $   improve code efficiency.
utsa 127      +*  ignorev(f)   = .f. 73, 08, fatra(f) **
utsa 128      +*  accessv(f)   = .f. 81, 08, fatra(f) **
utsa 129      +*  errorv(f)    = .f. 89, 08, fatra(f) **
utsa 130      +*  linenum(f)   = .f. 97, 24, fatra(f) **
utsa 131 ..s47
dsw   32 .+s40.
dsw   33      +*  strorgv(f)   = .f. 33, 16, fatra(f) **
dsw   34      +*  lbptr(f)     = .f. 49, 08, fatra(f) **
dsw   35      +*  lbmax(f)     = .f. 57, 08, fatra(f) **
dsw   36      +*  linenum(f)   = .f. 65, 16, fatra(f) **
dsw   37 ..s40
      64 .+s66.
      65      +*  strorgv(f)   = .f. 33, 17, fatra(f) **
      66      +*  lbptr(f)     = .f. 50, 08, fatra(f) **
      67      +*  lbmax(f)     = .f. 61, 08, fatra(f) **
      68      +*  linenum(f)     = .f. 69, 17, fatra(f) **
      69 ..s66
      70
      71      +*  fatrasz =  $ size of fatra.
dst   74 .+s10    144
      73 .+s11    80
vax   62 .+s32    128
      75 .+s37    128
utsa 132 .+s47    128
dsw   38 .+s40    80
      76 .+s66    120
      77          **
      78
      79      +* titlev(f) = titlevara(f) **
      80
      81      $   line buffers for little io are allocated in iolba.  iolbamax
      82      $   gives upper bound on sum of line lengths of simultaneously
      83      $   active formatted files.
      84      +*  iolbamax =
dsua   7 .+s10    1000
dsu   19 .+s11    400
dsf   82 .+s32    1000
dse   32 .+s37    500
utsa 133 .+s47    1000
dsw   39 .+s40    300
      89 .+s66    80
      90      **
      91
      92
      93      +*  iolb(c, f) = $ reference c-th char in line buffer of file -f-.
      94          .f. 1 + cs*(cpw - c + cpw*((c-1)/cpw)), cs,
      95          iolba(iolborg(f) + (c-1)/cpw) **
      96
      97
      98      +* ifcanput(t) = .f. t, 1, 1b'110110' ** $ can we put to type f.
      99      +* ifcanget(t) = .f. t, 1, 1b'011001' ** $ can we get from type f.
     100      +* isbinary(t) = .f. t, 1, 1b'101000' ** $ if type t is binary
     101      +* isoutput(t) = .f. t, 1, 1b'100110' ** $ if type t output.
     102      +*  isputorprint(t) = .f. t, 1, 1b'000110' **
     103
     104      /*  all conversions take place in the global conversion
     105          buffer, of length -gcblim- characters.  the worst
     106          case is conversion of a binary octal string of length
     107          -szmax- which requires at least -szmax- characters.
     108          most implementations will undoubtedly limit the length
     109          of a single conversion. */
     110      +*  gcblim =
dsv  154 .+s10    200
     112 .+s11    135
dse   33 .+s32    240
dse   34 .+s37    240
utsa 134 .+s47    240
dsw   40 .+s40    135
     115 .+s66    240
     116          **
     117
     118
     119
     120 $    to avoid conflicts with names of user procedures, the names of io
     121 $    procedures begin with a four character code followed by a string
     122 $    not usually found in names, but acceptable to the loader.
     123 $    if possible, the trailer string should be '$io', as we expect
     124 $    most loaders accept the character '$'.
     125 $    if this string must be changed, consult use and definition of
     126 $    -iorts- option in parser source.
     127
dsw   41 .-s40.          $ no trailer string for s40
     129      +*  cefr = 7ncefr$io **  $ convert exponent, fraction to real.
     130      +*  cref = 7ncref$io  **  $ convert real for output.
     131      +*  deci = 7ndeci$io  **  $ convert integer for output.
     132      +*  flsh = 7nflsh$io  **  $ flush formatted output file
     133      +*  frew = 7nfrew$io  **  $ rewind file (sys)
     134      +*  fwef = 7nfwef$io  **  $ write eof (sys)
     135      +*  fwer = 7nfwer$io  **  $ write record mark (sys)
     136      +*  gcfp = 7ngcfp$io  **  $ control format processor
     137      +*  ifma = 7nifma$io  **  $ -a- input format
     138      +*  ifmb = 7nifmb$io  **  $ -b- input format
     139      +*  ifme = 7nifme$io  **  $ -e- input format
     140      +*  ifmf = 7nifmf$io  **  $ -f- input format
     141      +*  ifmi = 7nifmi$io  **  $ -i- input format
     142      +*  ifmr = 7nifmr$io  **  $ -r- input format
     143      +*  iget = 7niget$io  **  $ get main procedure.
     144      +*  ilst = 7nilst$io  **  $ get list mode.
     145      +*  ioer = 7nioer$io  **  $ error processor
     146      +*  ions = 7nions$io  **  $ io nameset.
     147      +*  ioqu = 7nioqu$io  **  $ io query
     148      +*  iore = 7niore$io  **  $ io request
     149      +*  iost = 7niost$io  **  $ create and open std. get, put files
     150      +*  istr = 7nistr$io  **  $ input streaming procedure
     151      +*  lpin = 7nlpin$io  **  $ set initial position values.
     152      +*  makf = 7nmakf$io  **  $ make system tables for file
     153      +*  pfin = 7npfin$io  **  $ complete formatted put.
     154      +*  ogrp = 7nogrp$io  **  $ put group constructor.
     155      +*  pdec = 7npdec$io  **  $ put integer digits.
     156      +*  ofma = 7nofma$io  **  $ -a- output format
     157      +*  ofmb = 7nofmb$io  **  $ -b- output format
     158      +*  ofme = 7nofme$io  **  $ -e- output format
     159      +*  ofmf = 7nofmf$io  **  $ -f- output format
     160      +*  ofmi = 7nofmi$io  **  $ -i- output format
     161      +*  ofmr = 7nofmr$io  **  $ -r- output format
     162      +*  onma = 7nonma$io  **  $ -n- array element name
     163      +*  onmv = 7nonmv$io  **  $ -n- simple name list
     164      +*  ostr = 7nostr$io  **  $ output streaming procedure
     165      +*  pcsa = 7npcsa$io  **  $ process character for string access.
     166      +*  putf = 7nputf$io  **  $  write print line through host io
     167      +*  pter = 7npter$io  **  $ io error processor
     168      +*  prfi = 7nprfi$io  **  $ print file (s66)
     169      +*  rdrb = 7nrdrb$io  **  $ read binary slice (sys)
     170      +*  rlse = 7nrlse$io  **  $ release file.
     171      +*  rwnd = 7nrwnd$io  **  $ rewind file.
     172      +*  sigl = 7nsigl$io  **  $ set ignore level.
     173      +*  uinp = 7nuinp$io  **  $ unformatted input
     174      +*  unna = 7nunna$io  **  $ io internal
     175      +*  uout = 7nuout$io  **  $ unformatted output
     176      +*  vali = 7nvali$io  **  $ validate io.
     177      +*  vnum = 7nvnum$io  **  $ verify numeric constant.
     178      +*  wtrb = 7nwtrb$io  **  $ write binary (sys)
dsw   42 ..s40
     180
     181      /*  macros for standard io prologues and functions. */
     182
     183      $   fields of io paramter string.
     184      +*  iop_lm = .f. 01, 01, **  $ on if listing mode.
     185      +*  iop_fw = .f. 02, 08, **  $ field width.
     186      +*  iop_dw = .f. 10, 05, **  $ decimal (or byte) width.
     187      +*  iop_sz = .f. 17, 11, **  $ size of datum.
     188      +*  iop_gw = .f. 28, 04, **  $ group width.
     189
     190      +*  iopsz = 32 **  $ size of io parameter string.
     191
     192      +* putg(c) =  $ add character to gcb.
     193          gcbptr =  gcbptr+(gcbptr<1 ! fileid>maxfiles  then $ if out of range.
     237              ioerror(fileid, 2, 2);
     238              end if;
     239          **
     240
     241      +*  chklioconn(f) = $ check that file f connected.
     242          if  accessv(f) = 0  then
     243              ioerror(f, 2, 3);
     244              end if;
     245          **
     246
       1 .=member ltllio
       2      subr ltllio(c);   $ io executive.
       3
       4      size  c(ps);            $ action (1=start, 2=finis).
       5      nameset ions;     $ global conversion buffer.
       6      $   printfileopen is set to one when standard print file opened.
       7      size  printfileopen(1);  data printfileopen = no;
       8      size titlevara(.sds. filenamelen); dims titlevara(maxfiles);
       9      size  ostr_rc(ws);     $  return code from ostr.
      10      size  get_fc(ps);       $ get format code.
      11      size  get_iop(iopsz);   $ copy of get io parm string.
      12      size  ilst_rc(ws);      $ get return code.
      13      size  istr_rc(ws);     $ istr return code.
      14      size  get_not(ps);      $ get 'global' do not bit.
      15      size  deci_arg(ws);  $ binary integer input for conversion.
      16      $   deci_lzero is nonzero if want at least deci_lzero digits
      17      $   in integer conversion.  leading zeros added if needed.
      18      size  deci_lzero(ps);
      19
      20      size  deci_msd(ps);  $ index in deciara of most significant dig.
      21      $   deci_nsd is zero if all digits are to converted.  if nonzero
      22      $   then only first deci_nsd digits are converted.
      23      size  deci_nsd(ps);
      24
      25      $   deci_sign is zero if positive sign is not to be represented.
      26      $   1 - negative sign represented by minus.
      27      $   2 - positive sign represented by plus.
      28      size  deci_sign(ps);
      29
      30      size  deci_unit(ps);    $ index in deciara of 'units' digit.
      31      size  deciara(ws);  dims deciara(deciaralen);  $ integer conversio
      32      size  gcbptr(ps);       $ on output, index of last char avail.
      33      size  get_mode(1);    $ on if list mode input.
      34      size  get_bw(ps);      $ byte width of l mode byte constant.
      35      size  get_char(cs);   $ character for list mode input.
      36      size  get_fw(ps);      $ number of characters istr is to get.
      37      size  get_expval(ws);   $ value of exponent.
      38        size gcb(ws);
      39        dims gcb(gcblim);
      40      size  istr_file(ps);    $ istr file.
      41      size  ostr_file(ps);    $ osrt (and flsh) file.
      42      size  filenow(ps);      $ current file.
      43      size  fatra(fatrasz);  dims fatra(maxfiles);
      44      size  iolblistptr(ps);
      45      size  iolblist(ps);  dims iolblist(maxfiles);
      46      size  iolborg(ps);  dims iolborg(maxfiles);
      47      size  iolblen(ps);  dims iolblen(maxfiles);
      48      size  iolbaptr(ps);
      49      size  iolba(ws);   dims iolba(iolbamax);
      50        end nameset ions;
      51      size  fi(ps);
dsi   75      size  iorc(ws);         $ io return code.
      52
      53
      54      if  c  then  $ if termination desired.
      55          do  fi = maxfiles to 3 by -1;  $ inverse order.
      56              if  (accessv(fi))  call rlse(fi);
      57              end do;
      58          call rlse(1);  call rlse(2);  $ print file last.
      59          return;
      60          end if;
      61
      62      deci_lzero = 0;   deci_nsd = 0;   deci_sign = 0;
      63      iolblistptr = 0;   iolbaptr = 1;
      64
      65      do  fi = 1 to maxfiles;  $ initialize for each file.
      66          fatra(fi) = 0; titlev(fi) = '';  $ set file status.
      67          iolblen(fi) = 0;  iolborg(fi) = 0;
      68          end do;
      69
dsi   76      call eretsio(2, iorc, 2); $ set verbose return if open fails.
      70      call makf(2, 1b'1111', printfilename, access_print, pflen-1, 1);
dsf   83$ if cannot open standard output, terminate immediately.
dsf   84      if  accessv(2)=0  then  $ if could not open
dsf   85          call remarkl('cannot open standard output.');
dsf   86          $ call sysfin directly, as standard output not available.
dsj   13          call sysfin(1, 1007);
dsf   88          end if;
dsi   77      call eretsio(2, iorc, 0);  $ set to quit if errors.
dsi   78
dsi   79      call eretsio(1, iorc, 1);  $ set terse return if open fails.
      71      call makf(1, 1b'1111', inputfilename, access_get, 0, 0);
dsi   80      call eretsio(1, iorc, 0);  $ set to quit if errors.
      72      end subr ltllio;
       1 .=member makf
       2      subr makf(farg, givarg, namearg, accarg, lnsarg, ignarg); $ make f
       3      size  farg(ps);         $ file number.
       4      $   givarg has bit -i- set if i-th attribute specified.
       5      size  givarg(ps);
       6      size  givens(ps);       $ local copy of givarg.
       7      size  namearg(.sds.filenamelen);  $ external name.
       8      size  accarg(ws);       $ type of access.
       9      size  lnsarg(ws);       $ line size.
      10      size  ignarg(ws);       $ ignore level.
      11      size  lnsval(ps);       $ copy of lnsarg.
      12      size  ignval(ps);       $ copy of ignarg.
      13      $   namearg, accarg, lnsarg and ignarg are -1 if not given in
      14      $   file statement, in which case prior values are to be
      15      $   inherited if possible.
      16      size  fileid(ps);       $ file number.
      17      size  newname(.sds. filenamelen);  $ new external name.
      18      size  i(ps);            $ loop index.
      19      size  ret(ps);          $ return code from oensio.
      20      size  ln(ps);           $ name length.
      21      size  memptr(ps);         $ returns address of argument.
      22      size  lnsret(ps);       $ open returned linesize.
      23      size  accold(ps),  accnew(ps);  $ prior, new access codes.
      24      access ions;
      25
      26      $   establish file correspondence.
      27
      28      fileid = farg;
      29      chkliorange(fileid);
      30 .+makfprfi  call prfi(fileid,'entry to makf');
      31
      32      givens = givarg;        $ find parameters actually specified.
      33
      34 .+ignoreinfilestatement.
      35      if  .f. 4, 1, givens  then  $ if ignore specified.
      36          ignorev(fileid) = ignarg;
      37          $ if ignore and access only specified, now pretend
      38          $   that only access specified.
      39          if  (givens = 1b'1010')  givens = 1b'0010';
      40          if  givens = 1b'1000'  then  $ if only ignore specified.
      41              go to ret;  end if;
      42          end if;
      43 ..ignoreinfilestatement
      44
      45      $   only can refer to file 2 once to open it (cf. ltllio).
      46      if  fileid=2  then
      47          if  (printfileopen)  then  ioerror(2, 2, 18);  end if;
      48          printfileopen = yes;
      49          end if;
      50
      51      accnew = accarg;  accold = accessv(fileid);
      52
      53      if  givens = 1b'0010'  then  $ if access alone specified.
      54          if  accnew = access_release  then  $ if releasing.
      55              call rlse(fileid);  go to ret;
      56              end if;
      57          if  ((accold=access_put ! accold=access_print) &
      58               accnew=access_get)
      59              !  (accold=access_write & accnew=access_read)  then
      60              $ here if changing from output to input.
      61              call rwnd(fileid, accnew);
      62              writing(fileid) = no;
      63              errorv(fileid) = no;
      64              canget(fileid) = yes;  canput(fileid) = no;
      65              accessv(fileid) = accnew;
      66              go to ret;
      67          else  $ illegal case.
      68              ioerror(fileid, 2, 4);  go to ret;
      69              end if;
      70          end if;
      71
      72      $   here to terminate existing connection and prepare to set up
      73      $   new one.
      74
      75      if  accold  then  $ if existing connection.
      76          call rlse(fileid);
      77          end if;
      78
      79 .+ignoreinfilestatement.
      80      $   if ignore not specified, pick default.
      81      if  .f. 4, 1, givens  then
      82          ignval = ignarg;
      83      else  $ pick default.
      84          ignval = (accnew = access_print) ! (accnew = access_string);
      85          end if;
      86 .-ignoreinfilestatement.
      87      ignval = (accnew = access_print) ! (accnew = access_string);
      88 ..ignoreinfilestatement.
      89
      90      ignorev(fileid) = ignval;
      91      accessv(fileid) = accnew;
      92      canput(fileid) = ifcanput(accnew);
      93      canget(fileid) = ifcanget(accnew);
      94      binaryv(fileid)= isbinary(accnew);
      95      lnsval = lnsarg * (.f. 3, 1,givens); $ set linesize if given.
      96      if  (lnsval^=0 & accnew=access_print)  lnsval = lnsval+1;
      97      iolblen(fileid) = 0;
      99
     100      if  accnew = access_string  then  $ if string
     101          strorgv(fileid) = memptr(namearg);
     102          titlev(fileid) = '';
     103          lnsret = lnsval;
     104          go to allobuf;
     105          end if;
     106      newname = filenamelenblanks;
     107      ln = slen namearg;
     108      if  (ln>filenamelen)  ln = filenamelen;
     109      do  i = 1 to ln;
     110          .ch. i, newname = .ch. i, namearg;
     111          end do;
     112      slen newname = ln;
     113
dsb   50      titlev(fileid) = newname;
     114      call opensio(fileid, ret, accnew, newname, lnsval, lnsret, 0, 0);
dsf   89      if  ret then $ if cannot open, set access type to zero.
dsf   90          accessv(fileid) =  0;
dsf   91          go to ret;
dsf   92          end if;
dsnb   1      if  accnew=access_get then $ if can get, set prompt
dsna   5          call promsio(fileid,ret,termprompt);
dsn   28          end if;
     116 /allobuf/    $ here to allocate line buffer if need one.
     117
     118      linesizev(fileid) = lnsret;
dsy    8      call lpin(fileid);  $ initialize line pointer.
     119      if  (lnsret)  iolblen(fileid) = (lnsret-1)/cpw + 1;
     120
     121      if  iolblen(fileid)  then  $ if need buffer
     122          if  iolblen(fileid) + iolbaptr <= iolbamax  then
     123              iolborg(fileid) = iolbaptr;
     124              do  i = 0 to iolblen(fileid)-1;  $ clear buffer.
     125                  iolba(iolbaptr+i) = blankword;
     126                  end do;
     127              iolbaptr = iolbaptr + iolblen(fileid);
     128              iolblistptr = iolblistptr+1;
     129              iolblist(iolblistptr) = fileid;
     130          else
     131              ioerror(fileid, 2, 7);  $ if cannot allocate buffer.
     132              end if;
     133          end if;
     134 /ret/
     135 .+makfprfi  call prfi(fileid,'exit from makf');
     136      end subr makf;
       1 .=member lpin
       2      subr lpin(farg);  $ initialize line pointer.
       3      $   lpin contains code common to makf and rewi, which sets initial
       4      $   line position for coded files and clears various fields.
       5      access ions;
       6      size  farg(ps);        $ file number.
       7      size  fileid(ps);      $ working copy of file number.
       8      size  accnow(ps);       $ file access.
       9      size  lbp(ps);          $ new value of lbptr.
      10
      11      fileid = farg;
      12      chkliorange(fileid);
      13      chklioconn(fileid);
      14
      15      endseenv(fileid) = no;
      16      endack(fileid) = no;
      17      errorv(fileid) = 0;
      18      $   initialize lbptr if get, put, print or string.
      19      lbp = 0;
      20      accnow = accessv(fileid);
      21      if  accnow = access_string  then
      22          lbp = 1;
      23      elseif  accnow = access_print  then
      24          lbp = 2;  iolb(1, fileid) = 1r ;
      25      elseif  accnow = access_put  then
      26          lbp = 1;
      27      elseif  accnow = access_get  then
      28          lbp = 1 + linesizev(fileid);
      29          end if;
      30
      31      lbmax(fileid) = 0;  $ reset lbmax.
      32      lbptr(fileid) = lbp;
      33      linenum(fileid) = 0;  $ reset line number.
      34      end subr lpin;
       1 .=member sigl
       2      subr sigl(farg, iglev);  $ set ignore level for file.
       3      $   set ignore level for file.  accept even if file not connected,
       4      $   although value set will be lost when file opened.
       5      size  farg(ps);           $ file number.
       6      size  iglev(ps);          $ new ignore level.
       7      size  fileid(ps);         $ local copy of farg.
       8      access ions;
       9
      10      fileid = farg;
      11      chkliorange(fileid);
      12      ignorev(fileid) = iglev;
      13      end subr sigl;
       1 .=member rlse
       2      subr rlse(farg);        $ release file.
       3      size  farg(ps);         $ file number.
       4      access ions;
       5      size  fileid(ps);       $ copy of file number.
       6      size  accnow(ps);          $ type of file.
       7      size  j(ps), w(ps), fi(ps);  $ loop indexes.
       8      size  oldorg(ps), neworg(ps);  $ old, new line buffer origins.
       9      size  rc(ws);           $ return code.
      10
      11      fileid = farg;
      12      accnow = accessv(fileid);
      13      if  (accnow=0)  return;  $ if no file association.
      14      if  errorv(fileid)=0 & isoutput(accnow)  then
dsg    8          if  (accnow=access_put & lbptr(fileid)>1)
dsg    9              ! (accnow=access_print & lbptr(fileid)>2)  then
      17             ostr_file = fileid;  call flsh;
      18             end if;
      19          end if;
      20
      21      $   if file has line buffer allocated, free it.
      22      if  iolborg(fileid)  then
      23          if  iolblist(iolblistptr) = fileid  then $ if last, just get s
      24              iolbaptr = iolbaptr - iolblen(fileid);
      25          else  $ if not last, compact buffers above.
      26              do j = 1 to iolblistptr;
      27                  if  (iolblist(j)=fileid)  quit do;
      28                  end do;
      29              neworg = iolborg(fileid);
      30              do  fi = j+1 to iolblistptr;
      31                  oldorg = iolborg(iolblist(fi));
      32                  do w = 0 to iolblen(iolblist(fi))-1;
      33                      iolba(neworg+w) = iolba(oldorg+w);
      34                      end do w;
      35                  iolborg(iolblist(fi)) = neworg;
      36                  neworg = neworg + iolblen(iolblist(fi));
      37                  iolblist(fi-1) = iolblist(fi);
      38                  end do;
      39              iolbaptr = neworg;
      40              end if;
      41          iolblistptr = iolblistptr - 1;
      42          iolborg(fileid) = 0;
      43          iolblen(fileid) = 0;
      44          end if;
      45
      46      $   if actual file, close using sio.
      47      $ if not print, or string file.
      48      if  accnow^=access_string  then
      49          call clossio(fileid, rc);
dsb   52          if  rc  then  $  if cannot close file.
dsb   53              ioerror(fileid, 2, 21);
dsb   54              end if;
      50          end if;
      51      accessv(fileid) = 0;    $ clear file association.
      52      end subr rlse;
      53      subr rwnd(farg, accnew);  $ rewind file.
       1 .=member rwnd
       2      access ions;
       3      size  farg(ps);         $ file number.
       4      size  accnew(ps);       $ new access mode.
       5      size  fileid(ps);       $ local copy of farg.
       6      size  ret(ws);          $ return code.
       7      size  iot(ps);          $ access of file.
       8
       9      fileid = farg;
      10      chkliorange(fileid);
      11      chklioconn(fileid);
      12      iot = accessv(fileid);
      13      if  (iot=0)  return;  $ cannot rewind undefined file.
      14      if  errorv(fileid)=0 & isoutput(iot)  then
      15          if  isputorprint(iot)  &
      16             lbptr(fileid)>1  then
      17             ostr_file = fileid;  call flsh;
      18             end if;
      19          end if;
      20      if  iot ^= access_string  then  $ if not string, can rewind.
      21      $   the third argument for rewisio is nonzero if rewind is
      22      $   to change access, or zero to keep current access and
      23      $   rewisio is just to position file at start.
      24          call rewisio(fileid, ret, accnew);
dsb   55          if  ret  then  $ if cannot rewind file.
dsb   56              ioerror(fileid, 2, 22);
dsb   57              end if;
      25          end if;
      26      call lpin(fileid);  $ set initial position values.
      27      end subr rwnd;
       1 .=member prfi
       2 .+prfi.
       3 $
       4 $    purge this deck after debugging.
       5 $
       6      subr prfi(fileid,msg);
       7      access ions;
       8      size fileid(ps), msg(20*cs);
       9      size i(ps);
      10      endl;  textl(msg);  endl
      11      tintl('file number',fileid) endl
      12      textl('title=')  textl(titlev(fileid)) endl
      13      tintl('donotbit', donotbit(fileid))  endl
      14      tintl('sfbit', sfbit(fileid))  endl
      15      tintl('ignorev', ignorev(fileid))  endl
      16      tintl('io access', accessv(fileid))       endl
      17      tintl('end seen', endseenv(fileid))  endl
      18      tintl('end acknowledge', endack(fileid))  endl
      19      tintl('error', errorv(fileid))  endl
      20      tintl('linesize', linesizev(fileid))  endl
      21      tintl('lbptr', lbptr(fileid))  endl
      22      tintl('canget',canget(fileid))  endl
      23      tintl('canput',canput(fileid))  endl
      24      tintl('writing', writing(fileid))         endl
      25      tintl('line buff org',iolborg(fileid))
      26      tintl('line buff len',iolblen(fileid)) endl
      27      textl('end of file attribute list.')  endl;
      28      end subr prfi;
      29 ..prfi
       1 .=member vali
       2      subr vali(farg, act); $ validation procedure.
       3      access ions;
       4  $ set =writing= value for file.
       5      size  farg(ps);    $ file number.
       6      size fileid(ps), what(ps);
       7      size  wb(1);  $ on if want to write (output) to file.
       8      $   verify that file fileid attributes consistent with desired
       9      $   operation expressed in io parm string iop.  if not, issue
      10      $   error message and set donotbit.  if ok, clear donotbit and
      11      $   error fields, and set writing flag if writing to file.
      12      size  act(ps);          $ type of validation.
      13      $   .f. 1, 1, act on for read, .f. 2, 1, on for binary.
      14
      15      fileid = farg;
      16      chkliorange(fileid);
      17      chklioconn(fileid);  $ verify connection.
      18      filenow = fileid;  $ set file for this op.
      19      donotbit(fileid)=  0;  $turn donotbit off
      20     $    clear all error flags
      21      errorv(fileid)= 0;
      22      sfbit(fileid)= 0;
      23
      24      wb = .f. 1, 1, act;  $ on if want to write to file.
      25      if  wb  then  $ if want to write.
      26          if  (canput(fileid) = no)  go to valierr;
      27      else
      28          if  (canget(fileid) = no)  go to valierr;
      29          end if;
      30      writing(fileid) = wb;
      31      if  (binaryv(fileid) ^= .f. 2, 1, act)  go to valierr;
      32      return;
      33 /valierr/  $ here if validation fails.
      34      ioerror(fileid, 2, 8);
      35      end subr vali;
       1 .=member ioqu
       2      fnct ioqu(farg, c);  $ filestat function.
       3      access ions;
       4      $   return file attribute in response to filestat inquiry.
       5      $   1.  cursor
       6      $   2.  end
       7      $   3.  err
       8      $   4.  ignore
       9      $   5.  access
      10      $   6.  linesize
      11      $   7.  stream
      12      size ioqu (ws);
      13      size  farg(ps);          $ file id as argument.
      14      size fileid(ps), c(ps);
      15
      16      fileid = farg;
      17      chkliorange(fileid);
      18      $   require file connection unless query for access.
      19      if  c^=5  then
      20          chklioconn(fileid);
      21          end if;
      22      go to l(c) in 1 to 7;
      23 /l(1)/   $ return cursor position.
      24      ioqu = lbptr(fileid)- (accessv(fileid) = access_print);
      25      go to ret;
      26 /l(2)/   $ return nonzero if at end of file.
      27      endack(fileid) = 0;  $ acknowledge end checked.
      28      ioqu = endseenv(fileid);  go to ret;
      29 /l(3)/   $ return error state.
      30      ioqu = errorv(fileid);
      31      go to ret;
      32 /l(4)/   $ return ignore level.
      33      ioqu = ignorev(fileid);  go to ret;
      34 /l(5)/   $ return access.
      35      ioqu = accessv(fileid);  go to ret;
      36 /l(6)/   $ return linesize.
      37      ioqu = linesizev(fileid) - (accessv(fileid)=access_print);
      38      go to ret;
      39 /l(7)/   $ return nonzero if streaming forced.
      40      ioqu = sfbit(fileid);  go to ret;
      41 /ret/    $ return.
      42      end fnct ioqu;
       1 .=member pcsa
dsb   58 .-pcsa_env.
       2      subr pcsa(rc, putting, saddr, cpos, cval); $ process string access
       3  /*  process character for string access.  saddr is the address of a
       4      character string.  if this string is not correctly formed, set rc
       5      to one and return.  cpos is an index in the string.  if cpos is
       6      not a valid index for the string, set rc to two and return.
       7      if putting is nonzero, set the cpos-th character of the string to
       8      be cval.  if putting is zero, set cval to be the cpos-th character
       9      of the string.  */
      10
      11      size  rc(ps);           $ return code.
      12      size  putting(ps);      $ nonzero to insert character.
      13      size  saddr(ps);        $ address of string.
      14      size  cpos(ps);         $ character index.
      15      size  cval(cs);         $ character to get or put.
      16      size  strorg(ps);       $ string origin.
      17      size  strlen(ps);       $ current length of string.
      18      size  strwords(ps);     $ words in string.
      19      size  fword(ps);        $ word in string to process.
      20      size  fpos(ps);         $ starting position of character.
      21      size  wd(ws);           $ memory word.
      22
      23      size  memget(ws);           $ absolute memory reader.
      24
      25      $   sorg extraction complicated by possibility sorg and slen in
      26      $   different words (code assumes if so, slen is full word).
      27      wd = memget(saddr - (.sl./ws));
      28      strorg = .e. (1+.sl.) - ws*(.sl./ws), .so., wd;
      29      strlen = slen (memget(saddr));
      30      if  (strorg <= (.sl.+.so.))  go to giverr(1);  $ if org too small.
      31      strwords = strorg / ws;
      32      if  (strorg ^= (strwords*ws+1))   go to giverr(1);
      33      if  ((cpos<1) ! (cpos>strlen))  go to giverr(2);
      34      fpos = strorg - cpos*cs;
      35      if  (fpos <= (.sl.+.so.))  go to giverr(2);
      36      fword = fpos / ws;
      37      fpos = fpos - fword*ws;
      38      wd = memget(saddr-fword);
      39      if  putting  then  $ if inserting character.
      40          .f. fpos, cs, wd = cval;
      41          call memput(saddr-fword, wd);  $ store new word.
      42      else  $ if extracting character.
      43          cval = .f. fpos, cs, wd;
      44          end if;
      45      rc = 0;
      46      return;
      47 /giverr(1)/  $  here if string not well formed.
      48      rc = 1;  return;
      49 /giverr(2)/  $ here if cpos not valid index.
      50      rc = 2;  return;
      51      end subr pcsa;
dsb   59 ..pcsa_env
       1 .=member ostr
       2      subr ostr;  $ output with streaming.
       3      access ions;
       4      size  fw(ps);       $ total external field width or nbr lines flus
       5      size  lbp(ps);          $ entry value of lbptr for file.
       6                         $ 2 if physical output or system error
       7      access ions;
       8      size strfile(1);  $ 1 if string file, 0 if external file
       9      size  saddr(ps);           $ string address if string file.
      10      size  sarc(ps);            $ pcsa return code.
      11      size  lpmax(ps);    $ line buffer (or storage buffer) ptr maximum
      12      size  i(ps);   $ loop index
      13      size  j(ps);   $ loop index.
      14 $    initialization, buffer flushing, and truncation action
      15      ostr_rc = 0;
      16      if  gcbptr < 1  then
      17        return;  end if;   $ useless to do anything more.
      18      strfile = (accessv(ostr_file) = access_string);
      19
      20      lpmax =  linesizev(ostr_file);
      21      lbp = lbptr(ostr_file);
      22
      23      if  strfile  then $ string vs. external
      24          saddr = strorgv(ostr_file);
      25          end if;
      26
      27
      28      do  i = 1 to gcbptr;
      29          if  lbp > lpmax then   $ first, write out the
      30                                     $ line if it is full
      31
      32              lbptr(ostr_file) = lpmax+1;  $ restore lbptr.
      33              call flsh;
      34              sfbit(ostr_file) = 1;
      35              lbp = lbptr(ostr_file);
      36              if  (ostr_rc)  go to error;
      37              end if lbp;
      38
      39
      40          if  strfile  then          $ now, put -gcb(i)- into the line.
      41              call pcsa(sarc, 1, saddr, lbp, gcb(i));  $ put character.
      42              if  sarc  then
      43                  ioerror(ostr_file, 2, (13+sarc));  $ bad string.
      44                  end if;
      45          else
      46              iolb(lbp, ostr_file) = gcb(i);
      47              end if;
      48          lbp = lbp + 1;
      49      end do;
      50
      51      lbptr(ostr_file) = lbp;
      52      return;
      53 /error/
      54      lbptr(ostr_file) = lbp;
      55      end subr ostr;
       1 .=member flsh
       2      subr flsh;  $ flush formatted output buffer
       3      access ions;
       4      size  strfile(1);       $ 'is file of type string'
       5      size  lpmax(ps);              $ line buffer pointer maximum
       6      size  qsa(ps);                $ quoted string address (string file
       7      size  i(ps);           $ counter
       8      size  printsw(ps);             $ on for printer type files
       9      size  lborg(ps);            $ origin position for line blanking.
      10      size  lbp(ps);          $ copy of line buffer pointer.
      11      size  lbm(ps);          $ copy of lbmax value.
      12
      13      ostr_rc = 0;
      14      lpmax =  linesizev(ostr_file);
      15      strfile = (accessv(ostr_file) = access_string);
      16      printsw = (accessv(ostr_file) = access_print);
      17      lbp = lbptr(ostr_file);
      18      lbm = lbmax(ostr_file);
      19      if  (lbm > lbp)  lbp = lbm; $ set to last col if needed.
      20
      21      $   if string file, just reset; otherwise write line.
      22      if  strfile = no  then  $ if not string file.
      23          if  ostr_file = 2  then
      24              call putf;
dse   35          else
      26              call putwsio(ostr_file, ostr_rc, iolba,
      27                      iolborg(ostr_file), lbp-1);
      28          linenum(ostr_file) = linenum(ostr_file)+1;
      29              end if;
      30          lborg = iolborg(ostr_file) - 1;
      31          do  i = 1 to iolblen(ostr_file);
      32              iolba(lborg+i) = blankword;
      33              end do;
      34          end if strfile;
      35      lbptr(ostr_file) = 1 + printsw;
      36      lbmax(ostr_file) = 0;  $ reset lbmax.
      37    $ clear ostr buffer may be needed.
      38      if (printsw) iolb(1, ostr_file) =1r ;
      39      if (ostr_rc) go to error;         $ for external fil
      40      return;
      41
      42 /error/            $ physical or system error exit
      43      ostr_rc = 3;
      44      end subr flsh;
       1 .=member putf
       2      subr putf;  $ put line to standard print file.
       3      access ions;
       4      access lcpns;
       5
       6      size  lbp(ps);          $ copy of line buffer pointer.
       7      size  lbm(ps);          $ copy of lbmax value.
       8
       9      lbp = lbptr(2);  lbm = lbmax(2) + 1;
      10      if  (lbm > lbp)  lbp = lbm;  $ set to last column if needed.
      11      lbp = lbp - 1;
      12 .+unpk_env.
      13      $   pack line directly into lcp buffer.
      14      call 7nunpk$li(pfl, 1, iolba, iolborg(2), lbp);
      15 .-unpk_env.
      16      size j(ps);    $ loop counter
dsu   20      j = iolborg(2);
      18      do  pfcol = 1 to lbp;
      19          pfl(pfcol) = .f. ws+1 - cs - cs*mod(pfcol-1,cpw), cs,
      20              iolba(j+(pfcol-1)/cpw);
      21          end do;
      22 ..unpk_env
      23
      24      pfcol = lbp + 1;
      25      call endlr;  $ terminate line.
      26      end subr putf;
       1 .=member gcfp
       2      subr_putfmt(gcfp);  $ control format processor.
       3      $   process control format.
       4      size  j(ps);            $ loop index.
       5      size  n(ws);        $ count, may be negative (x item).
       6      size  c(ps);            $ type of control item.
       7      size  iot(ps);          $ access of file.
       8      size  lbp(ps);          $ entry value of lbptr.
       9      size  lbm(ps);          $ entry value of max.
      10      size  writecase(1);     $ on if writing to file.
      11      size  ret(ws);          $ return code.
      12
      13      n = .f. 1, ws, datum;
      14      c = iop;
      15      lbp = lbptr(filenow);
      16      lbm = lbmax(filenow);
      17      writecase = writing(filenow);
      18      iot = accessv(filenow);
      19
      20      go to l(c) in 1 to 4;
      21 /l(1)/  $ column control format item
      22
      23      n = n + (iot = access_print);
      24      if  n <= 0  ! (n > linesizev(filenow))  then
      25          go to parmerr;
      26      else
      27          if  (lbp > lbm)  lbmax(filenow) = lbp;
      28          lbptr(filenow) = n;
      29          endseenv(filenow) = 0;
      30          end if;
      31
      32      return;
      33
      34 /l(2)/  $ skip (some number of lines) control format item
      35      if (n = 0) return;
      36
      37      if  iot = access_string  then  $  reset on skip or page.
      38          lbptr(filenow) = 1;  lbmax(filenow) = 0;
      39          return;
      40          end if;
      41
      42      if  n < 0  !  n > 100  then
      43          go to parmerr;
      44      else
      45          do  i = 1 to n;
      46              if  writecase  then
      47                    ostr_file = filenow;
      48                  call flsh;
      49                  if  (ostr_rc) go to ostrerr;
      50              else
      51                      $  force istr to read new line.
      52                  get_fw = 1;  get_mode = 0;
      53                  istr_file = filenow;
      54                  lbptr(istr_file) = linesizev(istr_file)+1;
      55                  call istr;
      56                  ret = istr_rc;
      57                  if  (istr_rc) go to istrerr;
      58                  end if;
      59              end do;
      60          if  writecase = no  then lbptr(filenow) = 1;  end if;
      61        end if;
      62
      63      return;
      64 /l(3)/  $ page control format item
      65
      66                        $ storage output -p- item becomes -j(1)- item.
      67      if ((iot = access_string) & writecase)  go to l(2);
      68
      69      if  iot = access_print  then
      70             ostr_file = filenow;
      71          call flsh;
      72          if (ostr_rc) go to ostrerr;
      73          iolb(1, filenow) = 1r1;
      74      else
      75          go to parmerr;
      76          end if;
      77
      78      return;
      79 /l(4)/  $ space control format item
      80      if (n = 0) return;
      81
      82      if  n < 0  then  $ take back item
      83         n = (lbp) + n;
      84      $  permit retrieval of carriage control of print file.
      85          if  n < (1 - (iot=access_print))  then
      86          go to parmerr;
      87          else
      88              if  (lbp > lbm)  lbmax(filenow) = lbp;
      89              lbptr(filenow) = n + (iot=access_print);
      90              end if;
      91
      92      else   $ positive value in -x- item
      93          if  n > gcblim  then
      94              go to parmerr;
      95          else
      96              if  writecase  then
      97                  do i = 1 to n;
      98                      gcb(i) = 1r ;
      99                      end do;
     100                  gcbptr = n;
     101                  call pfin(iop, 0);  $ write out gcb.
     102              else
dsda   1                  i = n + lbptr(filenow);  $ desired position.
     104                  if  i < linesizev(filenow)  then
     105                      lbptr(filenow) = i;  $ if stay in current line.
     106                      ret = 0;
     107                  else  $ if x forces streaming, call istr.
     108                      get_fw = n;  get_mode = 0;
     109                      istr_file = filenow;  call istr;
     110                      if  (istr_rc)  go to istrerr;
     111                      end if;
     112                   end if;
     113              end if;
     114          end if;
     115
     116      return;
     117
     118 /istrerr/
     119 /ostrerr/
     120      $   here if transmission error or end seen.
     121      return;
     122 /parmerr/  $ here if bad parameter in control request.
     123      ioerror(filenow, 2, 16);
     124      return;
     125      end subr gcfp;
       1 .=member pfin
       2      subr pfin(ioparg, c);  $ complete formatted put.
       3      access ions;
       4      ostr_file = filenow;
       5      size  ioparg(iopsz);     $  io parameter list.
       6      $   c is termination type, as follows.
       7      $   0 - just call ostr (called from onma, onmv).
       8      $   1 - a, r formats. left align field.
       9      $   2 - b format.  right align field.
      10      $   3 - e, f, i formats.  groups already formed.
      11      size  c(ps);
      12      size  fw(ps);           $ field width.
      13      size  gw(ps);           $ group width.
      14      size  i(ps);            $ loop index.
      15      size  nb(ps);           $ number of blanks to insert.
      16      size  truncerr(ps);     $ on if truncation error.
      17
      18      truncerr = no;
      19      if  (c=0)  go to ostrdo;
      20      if  iop_lm  ioparg  then  $ if list mode.
      21          putg(1r );  $ terminate list field.
      22      else  $ if edit mode.
      23          gw = iop_gw ioparg;
      24          fw = iop_fw ioparg;
      25          if  fw >= gcblim  then  $ if fw too large, is truncation.
      26              fw = gcblim;
      27              truncerr = yes;
      28              end if;
      29          if  ((gw>0)&(c>0)&(c<3))  call ogrp(gw, c);  $ if groups.
      30          if  (fw > gcbptr)  then
      31              nb = (fw - gcbptr);
      32              if  c=1  then  $  if left aligned, add trailing blanks.
      33                  do  i = 1 to nb;
      34                      gcb(gcbptr+i) = 1r ;
      35                      end do;
      36              else  $  if right aligned, move and add leading blanks.
      37                  do  i = gcbptr to 1 by -1;  $ move data
      38                      gcb(i+nb) = gcb(i);
      39                      end do;
      40                  do  i = 1 to nb;
      41                      gcb(i) = 1r ;
      42                      end do;
      43                  end if;
      44              gcbptr = gcbptr + nb;
      45          elseif  fw < gcbptr  then  $ if possible truncation.
      46              if  (c=3) & (fw>0)  then
      47                  truncerr = yes;
      48                  end if;
      49              end if;
      50          end if;
      51
      52      if  (gcbptr >= gcblim)  truncerr = yes;
      53 /ostrdo/
      54      if  truncerr  then  $ if truncation, fill field with *.
      55          do  i = 1 to fw;  gcb(i) = 1r*;  end do;
      56          gcbptr = fw;
      57          end if;
      58      call ostr;
      59      if  ostr_rc  then   $ if ostr transmission error.
dsb   60          ioerror(filenow, 2, 17);
      61          end if;
      62      if  truncerr  then  $ if truncation error.
      63          ioerror(filenow, 1, 1);
      64          end if;
      65      end subr pfin;
       1 .=member ogrp
       2      subr ogrp(gw, c);  $ output group formation.
       3      access ions;
       4      $   form groups of gw characters each.  c gives type of group:
       5      $   c is one for groups formed from the left (a,r formats).
       6      $   c is two for -b- format groups formed from the right.
       7      size  gw(ps);           $  group width.
       8      size  c(ps);            $ type of grouping desired.
       9      size  i(ps);            $  loop index.
      10      size  inthis(ps);       $ characters inserted in current group.
      11      size  nc(ps);           $  number of data characters.
      12      size  ng(ps);           $  number of groups to form.
      13      size  np(ps);           $  position during grouping.
      14      size  gs(60);           $ bit i on if group in numeric case.
      15
      16      if  (gw<=0)  return;
      17      if  c < 3  then
      18          if  (gcbptr<=gw)  return;
      19          ng = (gcbptr-1) / gw;
      20          nc = gcbptr;
      21          inthis = 0;
      22          end if;
      23      if  c = 1  then  $ if groups from left.
      24      $   move data to right, then copy inserting group separating
      25      $   blanks.
      26          if  ((gcbptr+ng) > gcblim)  ng = gcblim - gcbptr;
      27          do  i = gcbptr to 1 by -1;
      28              gcb(i+ng) = gcb(i);
      29              end do;
      30          gcbptr = gcbptr + ng;
      31          np = 0;
      32          do  i = gcbptr-nc+1 to gcbptr;
      33              np = np + 1;
      34              gcb(np) = gcb(i);
      35              inthis = inthis + 1;
      36              if  inthis=gw & (i1)  then  $  if group complete.
      50                  np = np - 1;
      51                  gcb(np) = 1r ;
      52                  inthis = 0;
      53                  end if inthis;
      54              end do i;
      55      elseif c = 3  then  $ if numeric grouping, do in deciara.
      56          gs = 0;
      57          do  i = deci_unit - gw to deci_msd by -gw;
      58              .f. i, 1, gs = 1;
      59              end do;
      60          do  i = deci_unit + gw to deci_lsd-1 by gw;
      61              .f. i, 1, gs = 1;
      62              end do;
      63          ng = .nb. gs;       $ number of groups.
      64          if  (ng = 0)  return;
      65          np = deci_msd - ng - 1;
      66          do  i = deci_msd to deci_lsd;
      67              np = np + 1;
      68              deciara(np) = deciara(i);
      69              if  .f. i, 1, gs  then  $ if end of group, add blank.
      70                  np = np + 1;
      71                  deciara(np) = 1r ;
      72                  end if;
      73              if  (i = deci_unit)  deci_unit = np;  $ adjust unit pos.
      74              end do;
      75          deci_msd = deci_msd - ng;
      76          end if c;
      77      end subr ogrp;
       1 .=member deci
       2      subr deci;  $ convert integer to digit sequence.
       3      access ions;
       4      $   convert binary integer in deci_arg into sequence of numberic
       5      $   character codes in deciara.  deci_lsd gives index of least
       6      $   significant digit, deci_msd gives index of most significant
       7      $   digit.  if deci_nsd is nonzero on entry, then only deck_nsd
       8      $   digits are converted.  deci_lzero is nonzero on entry to
       9      $   indicate that leading zeros are to be added if necessary
      10      $   to obtain deci_lzero digits.
      11
      12      $   the code will work correctly on two's complement machines,
      13      $   which have a smallest negative integer whose absolute value is
      14      $   one more than the absolute value of the largest postive
      15      $   integer.
      16
      17      size  n(ps);        $ index.
      18      size  v(ws);        $ value to convert.
      19      size  i(ps);            $ loop indexes.
      20      size  d(ps);            $ current digit.
      21      size  di(ps);           $ index in ara to receive next digit.
      22      size  msdwant(ps);      $ desired value of msd if deci_nsd given.
      23
      24      v = deci_arg;
      25 .+itoc_env.  $ if environment conversion procedure.
      26      size  itocara(ws);  dims itocara((deciaralen/cpw)+1);
      27      call itoc(v, itocara, di);  $ convert.
      28      deci_msd = (deci_lsd+1) - di;
      29      call 7nunpk$li(deciara, deci_msd, itocara, 1, di);
      30 .-itoc_env.      $ if not done in environment.
      31      di = deci_lsd + 1;
      32      if  v >= 0  then  $ if nonnegative
      33          until  v = 0;
      34              di = di - 1;  $ move to next position.
      35              deciara(di) = charofdig((v-(v/10)*10));
      36              v = v/10;
      37              end until;
      38      else  $ if negative.
      39          until v = 0;
      40              di = di - 1;  $ move to next position.
      41              deciara(di) = charofdig((10*(v/10)-v));
      42              v = v/10;
      43              end until;
      44          end if;
      45      deci_msd = di;
      46 ..itoc_env
      47      deci_msd = di;            $ store position of msd.
      48      deci_unit = 0;  $ reset.
      49      $   if exactly deci_nsd digits desired, see if more obtained.
      50      $   if so, remove extra digits.
      51      if  deci_nsd  then
      52          msdwant = deci_lsd + 1 - deci_nsd;  $ desired msd value.
      53          if  deci_msd < msdwant  then  $ if too many digits, drop exces
      54              n = deci_msd + deci_nsd - 1;
      55              do  i = 0 to deci_nsd-1;
      56                  deciara(deci_lsd-i) = deciara(n-i);
      57                  end do;
      58          elseif  deci_msd > msdwant  then  $ if too few, add zeros.
      59              n = deci_msd - msdwant;
      60              do  i = deci_msd to deci_lsd;
      61                  deciara(i-n) = deciara(i);
      62                  end do;
      63              do  i = 0 to n-1;
      64                  deciara(deci_lsd-i) = 1r0;
      65                  end do;
      66              end if;
      67          deci_msd = msdwant;
      68          end if;
      69      deci_nsd = 0;  $ reset.
      70
      71      if  deci_lzero  then  $ if want at least deci_lzero digits.
      72          msdwant = deci_lsd + 1 - deci_lzero;
      73          if  msdwant < deci_msd  then  $ add leading zeros.
      74              do  i = msdwant to deci_msd-1;
      75                  deciara(i) = 1r0;
      76                  end do;
      77              deci_msd = msdwant;
      78              end if;
      79          deci_lzero = 0;
      80          end if;
      81
      82      end subr deci;
       1 .=member pdec
       2      subr pdec;  $ copy deciara contents to gcb.
       3      access ions;
       4      size  i(ps);            $ loop index.
       5      size  c(cs);      $ character for sign (if needed).
       6
       7      if  deci_sign  then  $ if need sign character.
       8          c = 1r+;  if  (deci_sign=1)  c = 1r-;
       9          putg(c);
      10          deci_sign = 0;  $ clear sign request.
      11          end if;
      12
      13      do  i = deci_msd to deci_lsd;
      14          putg(deciara(i));
      15          if  i = deci_unit  then  putg(1r.);  end if;
      16          end do;
      17      end subr pdec;
       1 .=member ofma
       2      subr_putfmt(ofma); $ -a- output format.
       3      $   output character string.
       4      size  mode(ps);         $ conversion type.
       5      size  sl(ps), so(ps);   $ string length and origin.
       6      size  efw(ps);          $ effective field width.
       7      size  c(cs);            $ character in string
       8      size  fw(ps);           $ field width.
       9      size  lm(1);            $ on if list mode.
      10
      11      $   determine mode: 0=edit 1=list 2=list print.
      12      lm = iop_lm iop;  $ retrieve list mode.
      13      fw = iop_fw iop;  $ retrieve field width.
      14      mode = (lm ) * (1 + (accessv(filenow) = access_print));
      15      $   determine effective field width.
      16      sl = .len. datum;  so = sorg datum;
      17      if  (fw > gcblim)  fw = gcblim;
      18      if  (fw = 0)  fw = sl;
      19      efw = sl;  if  (efw > fw)  efw = fw;
      20 .+ofsa_env.   $ avoid use of gcb if no streaming occurs.
      21      size  lbp(ps);          $ line buffer position.
      22      size  lsv(ps);          $ linesize value.
      23      size  gw(ps);           $ group width.
      24
      25      if  mode=0  then  $ can only zip through in edit mode.
      26          lbp = lbptr(filenow);  lsv = linesizev(filenow);
      27          gw = iop_gw iop;
      28          if  accessv(filenow)^=access_string
      29              & (lbp+fw <= lsv+1)  & (gw=0)  then
      30              call 7nofsa$li(iolba, iolborg(filenow), lbp,
      31                  datum, efw, fw-efw);
      32              lbptr(filenow) = lbp + fw;
      33              return;
      34              end if;
      35          end if;
      36 ..ofsa_env
      37      $   verify sds structure.
      38      gcbptr = 0;
      39      if  (mode = 1)  then putg(1r');  end if;
      40      do  i = 1 to efw;
      41          c = .f. so - i*cs, cs, datum;
      42          if  c = 1r'  then  $ if quote, see if should double.
      43              if  (mode = 1)  then  putg(1r');  end if;
      44              end if;
      45          putg(c);
      46          end do;
      47
      48      if  (mode = 1)  then  putg(1r');  end if;
      49      call pfin(iop, 1);
      50      end subr ofma;
       1 .=member ofmb
       2      subr_putfmt(ofmb);  $ -b- output format.
       3      size  c(cs);            $ character.
       4      size  efw(ps);          $ effective field width.
       5      size  bw(ps);           $ byte width.
       6      size  sz(ps);           $ datum size.
       7      size  msb(ps);          $ most significant bit to convert.
       8      size  j(ps);            $ loop index.
       9      size  bv(4);            $ byte from datum.
      10      size  lm(1);            $ on if list mode.
      11      size  fw(ps);           $ field width.
      12      $   verify bw.
      13      lm = iop_lm iop;  $ retrieve list mode.
      14      fw = iop_fw iop;  $ retrieve field width.
      15      bw = iop_dw iop;
      16      if  lm & (fw>0)  then  $ if list mode, fw is actually bw.
      17          bw = fw;
      18          fw = 0;
      19          end if;
      20      if  (bw<1 ! bw>4)  bw = mradix;  $ for valid bw if not in range.
      21      gcbptr = 0;
      22      sz = iop_sz iop;
      23      if  lm  then  $ if list mode, put bfw and apostrophe.
      24          putg(charofdig(bw)); putg(1rb); putg(1r');
      25          end if;
      26      if  fw  then  $ if fw given, use fw to determine msd to convert.
      27          msb = fw * bw;
      28      else
      29          msb = sz + 1;
      30          end if;
      31      if  (msb > sz)  msb = sz;
      32
      33      $   correct approximation to msb by examining data.
      34      while  (.f. msb, 1, datum) = 0;
      35          if  (msb=1) quit while;
      36          msb = msb - 1;
      37          end while;
      38
      39      do  i = ((msb+bw-1)/bw -1)*bw to 0 by -bw;
      40      $   can do full byte unless near end or would cross word boundary.
      41 .+wsm3   if  (i+bw <= sz)  then
      42 .-wsm3   if  (i+bw<=sz) & ((i+bw-1)/ws = i/ws)  then
      43              bv = .f. i+1, bw, datum;
      44          else  $ if near end of datum, get bit by bit.
      45              bv = 0;  $ clear byte.
      46              do  j = 1 to bw;
      47                  .f. j, 1, bv = .f. i+j, 1, datum;
      48                  if ((i+j)=sz)  quit do;
      49                  end do;
      50              end if;
      51          putg((.ch. bv+1, '0123456789abcdef'));
      52          end do;
      53
      54      if  (lm)  then  putg(1r');  end if;
      55
      56      call pfin(iop, 2);
      57      end subr ofmb;
       1 .=member ofme
       2 .-fp.  $ error exit if floating point not supported.
       3      subr ofme(datum, ioparg);  $ ofme fatal if fp not supported.
       4      size  datum(szmax), ioparg(iopsz);
       5      call ltlfin(1, 1008);  $ floating point not supported.
       6      end subr ofme;
       7 .+fp.
       8      subr_putfmt(ofme);  $ -e- output format.
       9      size  nsd(ps);          $ number of significant digits.
      10      size  eint(ws);         $ signed exponent value.
      11      size  fint(ws);         $ signed fraction value.
      12      size  signed(1);        $ on if negative value.
      13      size  fw(ps);           $ field width.
      14      size  dw(ps);           $ decimal (or byte) width.
      15      size  gw(ps);           $ group width.
      16      size  lm(ps);           $ list mode.
      17
      18      fw = iop_fw iop;  $ retrieve field width.
      19      dw = iop_dw iop;  $ retrieve digit width.
      20      gw = iop_gw iop;  $ retrieve group width.
      21      lm = iop_lm iop;  $ get list mode.
      22      if  lm & (fw>1)  then  $ if list mode, fw is nsd.
      23          dw = fw - 1;
      24          fw = 0;
      25          end if;
      26      if  (dw=0)  dw = 5;
      27      nsd = dw + 1;
      28      gcbptr = 0;
      29      call cref(datum, nsd, eint, fint);
      30      signed = (fint<0);
      31
      32      if  fint = 0  then  $ if 0.0.
      33          putg(1r0); putg(1r.);
      34      else
      35          deci_arg = fint;  $ convert to decimal digits.
      36          deci_nsd = nsd;
      37          call deci;
      38          deci_unit = deci_msd;
      39          if  gw  then  call ogrp(gw,3);  end if;
      40          deci_sign = signed;  $ sign only if negative.
      41          call pdec;
      42          putg(1re);
      43          deci_lzero = 2;  $ at least two digits in exponent.
      44          deci_arg = eint;  call deci;
      45          deci_sign = 2 - (eint<0);  $ sign required for exponent.
      46          call pdec;
      47          end if;
      48
      49      call pfin(iop, 3);
      50      end subr ofme;
      51 ..fp
       1 .=member ofmf
       2 .-fp.  $ error exit if floating point not supported.
       3      subr ofmf(datum, ioparg);  $ ofmf fatal if fp not supported.
       4      size  datum(szmax), ioparg(iopsz);
       5      call ltlfin(1, 1008);  $ floating point not supported.
       6      end subr ofmf;
       7 .+fp.
       8      subr_putfmt(ofmf);  $ -f- output conversion.
       9      size  n(ps);            $ number of spaces to move.
      10      size  unitwant(ps);     $ desired position of unit digit.
      11      size  e(ws);            $ signed exponent.
      12      size  fint(ws);         $ signed fraction value integer.
      13      size  nsd(ps);          $ number of significant digits.
      14      size  signed(1);        $ on if value negative.
      15      size  lm(1);            $ on if list mode.
      16      size  fw(ps);           $ field width.
      17      size  dw(ps);           $ decimal (or byte) width.
      18      size  gw(ps);           $ group width.
      19
      20      gcbptr = 0;
      21      lm = iop_lm iop;        $ get list mode.
      22      if  lm & (fw>0)  then  $ if list mode, fw is dw.
      23          dw = fw;
      24          fw = 0;
      25          end if;
      26      fw = iop_fw iop;  $ retrieve field width.
      27      dw = iop_dw iop;  $ retrieve digit width.
      28      gw = iop_gw iop;  $ retrieve group width.
      29      if  (fw=0)  fw = 8;  $ 6 digits, sign and point.
      30      if  (fw<3)  go to truncerr;  $ at least one digit, sign and point.
      31      nsd = 2;
      32      call cref(datum, nsd, e, fint);
      33      signed = (fint < 0);
      34      if  fint = 0  then  $ 0.0 is special case.
      35          e = 0;  $ clear exponent, since result zero.
      36          nsd = 1;  go to zerocase;
      37          end if;
      38      if  e >= 0  then  $ if positive exponent, add leading dig count.
      39          if  (fw>0) & (e > (fw-dw-2))  then  $ if overflow.
      40              go to truncerr;
      41              end if;
      42          nsd = e + dw + 1;
      43      else  $ no leading digits, determine nsd.
      44          e = 0 - e;
      45          if  (e > dw+1)  then
      46              e = 0;  $ clear exponent, since result zero.
      47              fint = 0;  nsd = 1;  go to zerocase;  $ rounds to zero.
      48          else  nsd = (dw+1) - e;  end if;
      49          end if;
      50      call cref(datum, nsd, e, fint);
      51 /zerocase/
      52      if  (nsd = 0)  nsd = 1;
      53      deci_arg = fint;  deci_nsd = nsd;
      54      call deci;
      55      deci_unit = deci_msd + e;
      56
      57      if  deci_unit < deci_msd  then  $ if need leading zeros.
      58          n = deci_msd - deci_unit;
      59          do  i = 1 to n;  deciara(deci_msd-i) = 1r0;  end do;
      60          deci_msd = deci_msd - n;
      61          end if;
      62
      63      unitwant = deci_lsd - dw;  $ desired position of units digit.
      64      if  deci_unit > unitwant  then  $ move left, add trailing zeros.
      65          n = deci_unit - unitwant;
      66          do  i = deci_msd to deci_lsd;
      67              deciara(i-n) = deciara(i);
      68              end do;
      69          do  i = 0 to n-1;  deciara(deci_lsd-i) = 1r0;  end do;
      70          deci_msd = deci_msd - n;
      71      elseif  deci_unit < unitwant  then  $ move right, drop trailing di
      72          n = unitwant - deci_unit;
      73          do  i = deci_lsd-n to deci_msd by -1;
      74              deciara(i+n) = deciara(i);
      75              end do;
      76          deci_msd = deci_msd + n;
      77          end if;
      78
      79      deci_unit = unitwant;
      80
      81      if  gw  then  call ogrp(gw, 3);  end if;
      82      deci_sign = signed;  $ give sign only if negative.
      83      call pdec;  $ add digits.
      84
      85 /ofmfdone/
      86      call pfin(iop, 3);
      87      return;
      88
      89 /truncerr/  $ here if truncation
      90      gcbptr = fw + 1;
      91      go to ofmfdone;
      92      end subr ofmf;
      93 ..fp
       1 .=member ofmi
       2      subr_putfmt(ofmi); $ -i- output format.
       3      size  v(ws);            $ conversion value.
       4      size  signed(1);        $ on if value negative.
       5      size  nsd(ps);          $ number of significant digits in value.
       6      size  lm(1);            $ on if list mode.
       7      size  fw(ps);           $ field width.
       8      size  dw(ps);           $ decimal (or byte) width.
       9      size  gw(ps);           $ group width.
      10      gcbptr = 0;
      11      lm = iop_lm iop;        $ get list mode.
      12      fw = iop_fw iop;        $ get field width.
      13      dw = iop_dw iop;        $ get digit width.
dst   75      gw = iop_gw iop;
      15      v = .f. 1, ws, datum;   $ is single word integer.
      16      deci_arg = v;
      17      deci_lzero = dw;  $ if want leading zeros.
      18      call deci;     $ convert integer.
      19      signed = (v<0);
      20      nsd = deci_lsd - deci_msd + 1;
      21
      22      if  gw  then            $ if groups desired.
      23          deci_unit = deci_lsd;
      24          call ogrp(gw, 3);
      25          deci_unit = 0;
      26          end if;
      27
      28      deci_sign = signed;  $ sign only if negative.
      29      call pdec;
      30
      31      call pfin(iop, 3);
      32      return;
      33      end subr ofmi;
       1 .=member ofmr
       2      subr_putfmt(ofmr);  $ -r- output format.
       3      size  gi(ps);  $ position in gcb
       4      size  di(ps);  $ position in datum
       5      size  tw(ps);  $ transmission width
       6      size  efw(ps);          $ effective field width.
       7      size  sz(ps);           $ datum size.
       8      size  lm(1);            $ on if list mode.
       9      size  fw(ps);           $ field width.
      10      size  dw(ps);           $ decimal (or byte) width.
      11
      12
      13      gcbptr = 0;
      14      lm = iop_lm iop;        $ get list mode.
      15      fw = iop_fw iop;        $ get field width.
      16      sz = iop_sz iop;
      17      dw = sz / cs;
      18      efw = fw;
      19      if  (efw > dw)  efw = dw;
      20      if  (efw = 0)  efw = 1;
      21      if  lm  then  $ if list mode, generate prefix.
      22          deci_arg = efw;  $ convert to decimal.
      23          call deci;
      24          call pdec;
      25          putg(1rr);
      26          end if;
      27      $   write member characters.
      28      do  i = (efw-1)*cs+1 to 1 by -cs;
      29          putg((.f. i, cs, datum));
      30          end do;
      31
      32      call pfin(iop, 1);
      33      return;
      34      end subr ofmr;
       1 .=member onmv
       2      subr onmv(datum); $ output variable name
       3      /*  output datum which is sds string generated by compiler
       4          giving name of variable mentioned in -n- format. */
       5      size  datum(ws+1);  $ sds naming variable
       6      size  sl(ws);   $ length of name
       7      size  i(ps);    $ do loop index for name copy to gcb
       8      access ions;
       9
      10      if  (donotbit(filenow)) return;
      11      sl = slen datum;
      12      gcbptr = 0;
      13      putg(1r );
      14      do  i = 1 to sl;
      15          putg((.ch. i, datum));
      16          end do;
      17      putg(1r=);
      18      call pfin( 0, 0);  $ put out gcb.
      19      end subr onmv;
       1 .=member onma
       2      subr  onma(datum, indexarg); $ print array name and inde
       3 $    print name of array and value of index - 'datum(index) ='
       4
       5      size  datum(szmax);  $ contains name of array
       6      size  indexarg(ws);  $ subscript value
       7      size  ret(ws);       $ return value from -ostr-
       8      size  sl(ps);        $ length of array name
       9      size  n(ps);         $ do loop index
      10      size  i(ps);            $ loop index.
      11      access ions;
      12
      13      if  (donotbit(filenow)) return;
      14      gcbptr = 0;
      15      putg(1r );
      16      sl = slen datum;
      17      do  i = 1 to sl;
      18          putg((.ch. i, datum));
      19          end do;
      20      putg(1r();
      21      deci_arg = indexarg;
      22      deci_lzero =  2;
      23      call deci;
      24      call pdec;
      25
      26      putg(1r));  putg(1r=);
      27      call pfin(0, 0);  $ put out gcb.
      28      end subr onma;
       1 .=member iget
       2      subr iget(datum);  $ get execu
       3      access ions;
       4      size  datum(szmax);     $ datum to convert.
       5      size  lm(1);            $ list mode flag.
       6      size  fw(ps);           $ field width.
       7      size  gw(ps);           $ group width.
       8      size  sz(ps);           $ datum size.
       9      size  dw(ps);           $ decimal width.
      10      size  np(ps);           $ position during group removal.
      11      size  i(ps);            $ loop index.
      12      size  inthis(ps);       $ number characters in current group.
      13      size  j(ps);            $ loop index.
      14      size  dmax(ps);         $ maximum acceptable digit for given bw.
      15      size  c(cs);            $ current character.
      16      size  d(ws);            $ value if character is digit.
      17      size  expgiven(ps);         $ index of -e- in numeric constant.
      18      size  esign(ps);        $ exponent sign (0=none, 1=+, 2=-).
      19      size  fsign(ps);        $ fraction sign (0=none, 1=+, 2=-).
      20      size  fdigits(ps);     $ position of decimal point.
      21      access ions;
      22      size  eval(ws);         $ absolute value of exponent.
dsi   81 .+mc size  ctpc(cs);         $ function to get primary case.
      23
      24      gcbptr = 0;
      25      if  (donotbit(filenow)) return;
      26      ilst_rc = 0;
      27      lm = iop_lm get_iop;        $ get list mode.
      28      fw = iop_fw get_iop;        $ get field width.
      29      gw = iop_gw get_iop;        $ get group width.
      30      sz = iop_sz get_iop;        $ get datum size.
      31      dw = iop_dw get_iop;        $ get decimal width.
      32      istr_file = filenow;
      33
      34      get_mode = lm;         $ set input mode.
      35      $   preset datum to zero.
      36      do  i = 1 to sz by ws;
      37          .f. i, ws, datum = 0;
      38          end do;
      39      if  lm  then  $ if list mode, call ilst to find field.
      40          get_fw = 1;
      41          call ilst;
      42          if  (ilst_rc)  go to vererr;
      43      else  $ if edit mode, call istr to read in field.
      44          get_fw = fw;
      45          if  (get_fc = get_fcb)  get_bw = dw;
      46          if  (fw=0)  go to vererr;
      47          gcbptr = fw;
      48          call istr;
      49          end if;
      50      if  (istr_rc)  go to istr_fail;
      51      if  gcbptr = gcblim  then  $ if truncation error
      52          go to vererr;
      53          end if;
      54
      55      if  lm = 0  then  $ if edit mode, process groups.
      56          if  gw  then  $ if groups, extract if -a- or -r- format.
      57              if  get_fc = get_fca ! get_fc = get_fcr  then  $ only a,r
      58                  inthis = 0;
      59                  np = 0;
      60                  do  i = 1 to gcbptr;
      61                      inthis = inthis + 1;
      62                      if  inthis <= gw  then $ if datum.
      63                          np = np + 1;
      64                          gcb(np) = gcb(i);
      65                      else  $ if end of group, skip char.
      66                          inthis = 0;
      67                          end if;
      68                      end do;
      69                  end if get_fc;
      70              gcbptr = np;
      71              end if gw;
      72          end if;
      73 $   verification required for b, e, f, i formats.
      74      if  get_fc = get_fcb  then  $ if b format,verify.
      75          if  (get_bw<1 ! get_bw>4)  go to vererr;
      76          dmax = .f. 1, get_bw, 15;  $ maximum allowed digit.
      77          np = 0;
      78          do  i = 1 to gcbptr;
      79              c = gcb(i);     $ get current character.
dsi   82 .+mc         c  = ctpc(c);  $ convert to primary case.
      80              if  (c = 1r )  cont do;  $ skip blanks.
      81              d = digofchar(c);  $ convert assuming decimal digit.
      82              if  get_bw < 4  then  $ if constant takes only digits.
      83                  if  (d<0 ! d > dmax)  go to vererr;
      84              else
      85                  if  d<0 ! d>9  then  $ see if hex char.
      86                      do  j = 1 to 6;
      87                          if  .ch. j, 'abcdef' = c  then
      88                                quit do;
      89                          else
      90                              if  (j=6)  go to vererr;
      91                                end if;
      92                          end do;
      93                      d = j + 9;
      94                      end if;
      95                  end if;
      96              np = np + 1;
      97              gcb(np) = d;
      98              end do;
      99          gcbptr = np;
     100      elseif get_fc = get_fce ! get_fc = get_fcf ! get_fc = get_fci
     101     then call vnum(gcb, gcbptr, get_expval);
     102          if  (gcb(gcbptr+2))  go to vererr;
     103          $   verify that if integer wanted, not floating point.
     104          if  get_fc = get_fci  then  $ if integer.
     105              if  (gcb(gcbptr+4) ! gcb(gcbptr+3))  go to vererr;
     106              end if;
     107          end if get_fc;
     108      return;
     109 /vererr/
     110      gcbptr = 0;  $ clear gcb, so no conversion done.
     111      ioerror(filenow, 1, 1);
     112      return;
     113 /istr_fail/
     114      donotbit(filenow) = 1;
     115      return;
     116      end subr iget;
       1 .=member istr
       2      subr istr;  $ input with streaming.
       3      access ions;
       4      size  i(ps);            $ loop index.
       5      access ions;
       6      size strfile(1);  $ 1 string file, zero if external file
       7      size  lbp(ps);          $ working copy of lbptr(istr_file).
       8      size  lsv(ps);          $ working copy of linesizev(istr_file).
       9      size  what(ps);     $ return parameter from -getc-
      10      size  memget(ps);  $ library function
      11      size  pfc(cs);      $ place for character
      12      size  saddr(ps);           $ string address if string file.
      13      size  sarc(ps);            $ pcsa return code.
      14 $    initialization and buffer flushing
      15      istr_rc = 0;
      16      lsv = linesizev(istr_file);
      17      lbp = lbptr(istr_file);
      18
      19      strfile = (accessv(istr_file) = access_string);
      20      if  strfile  then
      21          saddr = strorgv(istr_file);
      22      else
      23      $   if prior end just seen, user must acknowledge it.
      24          if  endack(istr_file)  then  $ if outstanding request.
      25              ioerror(istr_file, 2, 9);  $ unacknowledged end.
      26              end if;
      27          end if;
      28
      29
      30      if  get_fw > gcblim  then  $ if field too large.
      31          ioerror(istr_file, 2, 10);  $ fw too large.
      32          get_fw = gcblim;  $ take acceptable value.
      33          end if;
      34
      35      do  i = 1 to get_fw;
      36
      37      if  strfile  then
      38          if  lbp <= slen(memget(saddr))  then
      39              call pcsa(sarc, 0, saddr, lbp, pfc);  $ get character.
      40              if  sarc  then
      41                  ioerror(istr_file, 2, (10+sarc));  $ bad string.
      42                  end if;
      43              lbp = 1 + lbp;
      44          else
      45              lbp = 1;
      46              what = 1;
      47              go to error;
      48              end if  lbp;    $ end string case
      49      else
      50          if  lbp  >  lsv  then
      51              sfbit(istr_file) = 1;      $ a new line is needed
      52              endseenv(istr_file) = no;
      53              call getwsio(istr_file, what, iolba,iolborg(istr_file),
      54                  lsv);
      55          linenum(istr_file) = linenum(istr_file)+1;
      56              if  (what)  go to error;
      57              lbp = 1;
      58              end if;
      59          pfc = iolb(lbp, istr_file);
      60          lbp = 1 + lbp;
      61          end if;                   $ character has been obtained
      62
      63      if  get_mode  then  $ if list mode, return single char.
      64          lbptr(istr_file) = lbp;
      65          get_char = pfc;
      66          return;
      67          end if;
      68
      69
      70      gcb(i) = pfc;      $ put the character in pfc into
      71
      72      end do i;
      73
      74 /istrret/
      75      lbptr(istr_file) = lbp;
      76      return;
      77 /error/
      78      if  what = 1  then  $ if end seen.
      79          endseenv(istr_file) = yes;
      80          $ require user acknowledge end seen unless string file.
      81          if  strfile = no  then
      82              endack(istr_file) = yes;
      83              donotbit(istr_file) = yes;
      84              end if;
      85      elseif what > 1  then  $ if transmission error.
dsb   61          ioerror(istr_file, 2, 13);
      87          end if;
      88      go to istrret;
      89      end subr istr;
       1 .=member ilst
       2      subr ilst;  $ get -l- field.
       3      access ions;
       4      $   this procedure implements the 'free form' list mode input
       5      $   as an interpreter for a special machine.  the interpretive
       6      $   method is used to reduce code size.  the operations of the
       7      $   machine are as follows:
       8
       9      $   act - perform action p.
      10      $   add - add character, jmp to p.
      11      $   cmp - compare current character with creg(p), skip on match.
      12      $   dec - decrement numeric register, skip if result not zero.
      13      $   err - abnormal termination.
      14      $   fin - normal termination.
      15      $   get - get next character.
      16      $   int - collect integer, store value in numeric register.
      17      $   jmp - jump to location p.
      18      $   stc - store current character in character register p.
      19      $   tnr - test numeric register, skip if not zero.
      20      $   gnl - get next line (for skip during comments).
      21
      22      $   array lst is the machine memory.  array creg contains
      23      $   character code constants.  the first entry in creg is used to
      24      $   save the delimiting character of q and r constants.  the
      25      $   numeric register nreg contains the length prefix value for
      26      $   b, q and r constants.
      27
      28      size  creg(cs);  dims creg(10);  $ character registers.
      29      data  creg = 1r , 1r , 1r,, 1rr, 1r', 1rq, 1rb, 1r$, 1r/, 1r*;
      30      size  nreg(ws);         $ numeric register.
      31      size  d(ws);            $ value of decimal character.
      32      size  i(ps);            $ loop index.
      33      size  holdchar(1);      $ on to retain current character.
      34      size  lsp(ps);          $ position in scan table.
      35
      36      size  p(ps);            $ parmeter value of ls op.
      37      size  cnow(cs);         $ current character.
      38      size  ret(ws);          $ return code.
      39      size  lst(16);  dims lst(91);  $ scan machine memory.
dsi   83 .+mc size  ctpc(cs);         $ function to get primary case.
      40
      41      $   the little macroprocessor is used to assemble the program.
      42      $   the assembly is necessarily one-pass, so that labels used
      43      $   in the program must be defined before use, as follows.
      44      $   macros resolve labels in scan table.
      45          +*  l01 = 01 **
      46          +*  l02 = 05 **
      47          +*  l03 = 08 **
      48          +*  l04 = 15 **
      49          +*  l05 = 17 **
      50          +*  l06 = 24 **
      51          +*  l07 = 29 **
      52          +*  l08 = 37 **
      53          +*  l09 = 41 **
      54          +*  l10 = 45 **
      55          +*  l11 = 48 **
      56          +*  l12 = 52 **
      57          +*  l13 = 54 **
      58          +*  l14 = 56 **
      59          +*  l15 = 59 **
      60          +*  l16 = 61 **
      61          +*  l17 = 65 **
      62          +*  l18 = 66 **
      63          +*  l19 = 69 **
      64          +*  l20 = 72 **
      65          +*  l21 = 76 **
      66          +*  l22 = 81 **
      67          +*  l23 = 84 **
      68          +*  l24 = 88 **
      69
      70      $   macros for lscan opcodes.
      71      +*  ls_act = 01 **     +*  ls_add = 02 **
      72      +*  ls_cmp = 03 **     +*  ls_dec = 04 **
      73      +*  ls_err = 05 **     +*  ls_fin = 06 **
      74      +*  ls_get = 07 **     +*  ls_int = 08 **
      75      +*  ls_jmp = 09 **     +*  ls_stc = 10 **
      76      +*  ls_tnr = 11 **     +*  ls_gnl = 12 **
      77
      78      +* lsop(o,p) = o*256 + p , **
      79      data lst =   $ data for scan table.
      80
      81 $ begin by skip over sequence of blanks and commas.
      82 lsop(ls_get,   0) $    l01      get
      83 lsop(ls_cmp,   2) $             cmp     2      compare with blank
      84 lsop(ls_jmp, l02) $             jmp     l02    if not blank.
      85 lsop(ls_jmp, l01) $             jmp     l01    if blank.
      86 lsop(ls_cmp,   3) $    l02      cmp     3      comma
      87 lsop(ls_jmp, l20) $             jmp     l20    if not comma.
      88 lsop(ls_jmp, l01) $             jmp     l01    if comma.
      89
      90 $ here to branch according to format type.
      91 lsop(ls_act,   1) $    l03      act     1      branch on format type.
      92 lsop(ls_jmp, l04) $             jmp     l04    -a- format.
      93 lsop(ls_jmp, l07) $             jmp     l07    -b- format.
      94 lsop(ls_add, l09) $             add     l09    -e- format (numeric).
      95 lsop(ls_add, l09) $             add     l09    -f- format (numeric).
      96 lsop(ls_add, l09) $             add     l09    -i- format (numeric).
      97 lsop(ls_jmp, l11) $             jmp     l11    -r- format.
      98
      99 $ here for -a- format, see if quoted string or -q- constant.
     100 lsop(ls_cmp,   5) $    l04      cmp     5      compare with quote.
     101 lsop(ls_jmp, l06) $             jmp     l06    if not quote.
     102
     103 $ here if quoted string, get text, watching for double apostrophe
     104 lsop(ls_get,   0) $    l05      get
     105 lsop(ls_cmp,   5) $             cmp     5      compare with quote.
     106 lsop(ls_add, l05) $             add     l05    if not quote, add.
     107 lsop(ls_get,   0) $             get
     108 lsop(ls_cmp,   5) $             cmp     5      compare with quote.
     109 lsop(ls_jmp, l18) $             jmp     l18    if not quote, done.
     110 lsop(ls_add, l05) $             add     l05    if (double) quote, add
     111
     112 $ here if -q- constant.
     113 lsop(ls_int,   0) $    l06      int
     114 lsop(ls_get,   0) $             get
     115 lsop(ls_cmp,   6) $             cmp     6      compare with letter -q-
     116 lsop(ls_err,   0) $             err            if not -q-.
     117 lsop(ls_jmp, l12) $             jmp     l12    get delimited text.
     118
     119 $ here for -b- constant, get width, verify in range.
     120 lsop(ls_int,   0) $    l07      int            get byte width.
     121 lsop(ls_act,   2) $             act     2      verify byte width.
     122 lsop(ls_get,   0) $             get
     123 lsop(ls_cmp,   7) $             cmp     7      compare with letter -b-
     124 lsop(ls_err,   0) $             err            if not -b-.
     125 lsop(ls_get,   0) $             get
     126 lsop(ls_cmp,   5) $             cmp     5      compare with quote.
     127 lsop(ls_err,   0) $             err            if not quote.
     128 lsop(ls_get,   0) $    l08      get            get until quote termina
     129 lsop(ls_cmp,   5) $             cmp     5      compare with quote.
     130 lsop(ls_add, l08) $             add     l08    if not quote.
     131 lsop(ls_jmp, l17) $             jmp     l17    done if quote.
     132
     133 $ here for numeric, skip to blank or comma.
     134 lsop(ls_get,   0) $    l09      get            collect until blank or
     135 lsop(ls_cmp,   2) $             cmp     2      compare with blank.
     136 lsop(ls_jmp, l10) $             jmp     l10    if not blank.
     137 lsop(ls_fin,   0) $             fin            if blank.
     138 lsop(ls_cmp,   3) $    l10      cmp     3      comma.
     139 lsop(ls_add, l09) $             add     l09    if not comma.
     140 lsop(ls_fin,   0) $             fin            if comma.
     141
     142 $ here for -r- constant, get count, check for -r-.
     143 lsop(ls_int,   0) $    l11      int
     144 lsop(ls_get,   0) $             get
     145 lsop(ls_cmp,   4) $             cmp     4      compare with letter -r-
     146 lsop(ls_err,   0) $             err            if not -r-.
     147
     148 $ here for body of -q- or -r- constant.
     149 lsop(ls_tnr,   1) $    l12      tnr     1      see if count zero.
     150 lsop(ls_jmp, l15) $             jmp     l15    if count zero.
     151
     152 $ here if explicit count.
     153 lsop(ls_get,   0) $    l13      get
     154 lsop(ls_add, l14) $             add     l14    add character.
     155 lsop(ls_dec,   1) $    l14      dec     1      decrement count.
     156 lsop(ls_jmp, l17) $             jmp     l17    if count zero.
     157 lsop(ls_jmp, l13) $             jmp     l13    if chars remain.
     158
     159 $ here to get delimited text.
     160 lsop(ls_get,   0) $    l15      get            get delimiter.
     161 lsop(ls_stc,   1) $             stc     1      save delimiter.
     162 lsop(ls_get,   0) $    l16      get
     163 lsop(ls_cmp,   1) $             cmp     1      compare with if delimit
     164 lsop(ls_add, l16) $             add     l16    if not delimiter.
     165 lsop(ls_jmp, l17) $             jmp     l17    if delimiter, done.
     166
     167 $ here to verify comma or blank follows constant.
     168 lsop(ls_get,   0) $    l17      get
     169 lsop(ls_cmp,   2) $    l18      cmp     2      compare with blank.
     170 lsop(ls_jmp, l19) $             jmp     l19    if not blank.
     171 lsop(ls_fin,   0) $             fin
     172 lsop(ls_cmp,   3) $    l19      cmp     3      compare with comma.
     173 lsop(ls_err,   0) $             err
     174 lsop(ls_fin,   0) $             fin            if comma.
     175
     176 $ here to seek comment at start.
     177 lsop(ls_cmp,   8) $    l20      cmp     8      compare with dollar.
     178 lsop(ls_jmp, l21) $             jmp     l21    if not dollar.
     179 lsop(ls_gnl,   0) $             gnl            get next line.
     180 lsop(ls_jmp, l01) $             jmp     l01    continue initial scan.
     181 lsop(ls_cmp,   9) $    l21      cmp     9      compare with slash.
     182 lsop(ls_jmp, l03) $             jmp     l03    if not slash.
     183 lsop(ls_get,   0) $             get            get next character.
     184 lsop(ls_cmp,  10) $             cmp     10     compare with star.
     185 lsop(ls_err,   0) $             err            if not * after /.
     186 lsop(ls_get,   0) $    l22      get            seek */ ending.
     187 lsop(ls_cmp,  10) $             cmp     10     compare with star.
     188 lsop(ls_jmp, l22) $             jmp     l22    if not star.
     189 lsop(ls_get,   0) $    l23      get            seen *, seek /.
     190 lsop(ls_cmp,  10) $             cmp     10     compare with star.
     191 lsop(ls_jmp, l24) $             jmp     l24    if not star.
     192 lsop(ls_jmp, l23) $             jmp     l23    seen *, seek /.
     193 lsop(ls_cmp,  09) $    l24      cmp     9      compare with slash.
     194 lsop(ls_jmp, l22) $             jmp     l22    if not slash.
     195 lsop(ls_jmp, l01) $             jmp     l01    continue scan.
     196        0;
     197      macdrop(lsop)
     198      macdrop(l01)   macdrop(l02)   macdrop(l03)
     199      macdrop(l04)   macdrop(l05)   macdrop(l06)
     200      macdrop(l07)   macdrop(l08)   macdrop(l09)
     201      macdrop(l10)   macdrop(l11)   macdrop(l12)
     202      macdrop(l13)   macdrop(l14)   macdrop(l15)
     203      macdrop(l16)   macdrop(l17)   macdrop(l18)
     204      macdrop(l19)   macdrop(l20)   macdrop(l21)
     205      macdrop(l22)   macdrop(l23)   macdrop(l24)
     206
     207      holdchar = no;  $ holdchar set by -int- action to retain char.
     208      get_mode = yes;  $ indicate that getting in l mode.
     209      nreg = 0;
     210      lsp = 1;                $ start at first entry in scan table.
     211      ilst_rc  = 0;  $ clear return code.
     212
     213 /next/
     214      p = .f. 01, 08, lst(lsp);  $ get parameter value.
     215      go to l(.f. 09, 08, lst(lsp)) in 1 to 12;  $ branch on opcode.
     216
     217 /l(ls_act)/   $ perform action -p-.
     218      if  p = 1  then  $ jump according to format type.
     219          lsp = lsp + get_fc;  go to next;
     220      elseif  p = 2  then  $ verify byte width.
     221          get_bw = nreg;
     222          if  ((nreg<1) ! (nreg>4))  go to l(ls_err);
     223          lsp = lsp + 1;  go to next;
     224          end if;
     225
     226 /l(ls_add)/  $ add cnow to gcb.
     227      putg(cnow);
     228      lsp = p;  go to next;
     229
     230 /l(ls_cmp)/  $ compare cnow with creg(p), skip if match.
dsi   84 .+mc cnow = ctpc(cnow);  $ convert to primary case.
     231      lsp = lsp + 1 + (cnow = creg(p));  go to next;
     232
     233 /l(ls_dec)/  $ decrement nreg, skip if new value not zero.
     234      if  (nreg)  nreg = nreg - 1;
     235      lsp = lsp + 1 + (nreg ^= 0);  go to next;
     236
     237 /l(ls_err)/  $ error, force abnormal termination.
     238      ilst_rc = 1;
     239      return;
     240
     241 /l(ls_fin)/  $ normal termination.
     242      return;
     243
     244 /l(ls_get)/  $ get next character, end file gives error.
     245      if  holdchar  then  $ if holding char, return it.
     246          holdchar = no;
     247      else
     248          call istr;
     249          if  (istr_rc)  return;
     250          cnow = get_char;
     251          end if;
     252      lsp = lsp + 1;  go to next;
     253
     254 /l(ls_jmp)/  $ jump to position -p-.
     255      lsp = p;  go to next;
     256
     257 /l(ls_stc)/  $ store cnow in creg(p).
     258      creg(p) = cnow;
     259      lsp = lsp + 1;  go to next;
     260
     261 /l(ls_tnr)/  $ test numeric register, skip if not zero.
     262      lsp = lsp + 1 + (nreg ^= 0);  go to next;
     263
     264 /l(ls_int)/  $ collect integer, error if not present.
     265      nreg = 0;
     266      d = digofchar(cnow);
     267      if  ((d < 0) ! (d > 9))  go to l(ls_err);
     268      while 1;
     269          nreg = nreg*10 + d;
     270          istr_file = filenow;  call istr;
     271          if  (istr_rc)  return;
     272          cnow = get_char;
     273          d = digofchar(cnow);
     274          if  ((d < 0) ! (d > 9))  quit while;
     275          end while;
     276      holdchar = yes;
     277      lsp = lsp + 1;  go to next;
     278
     279 /l(ls_gnl)/  $ get new line (after $ comment header seen).
     280      lbptr(istr_file) = linesizev(istr_file) + 1;
     281      holdchar = no;
     282      go to l(ls_get);
     283
     284      macdrop(ls_act)  macdrop(ls_add)  macdrop(ls_cmp)
     285      macdrop(ls_dec)  macdrop(ls_err)  macdrop(ls_fin)
     286      macdrop(ls_get)  macdrop(ls_int)  macdrop(ls_jmp)
     287      macdrop(ls_stc)  macdrop(ls_tnr)  macdrop(ls_gnl)
     288      end subr ilst;
       1 .=member ifma
       2      subr ifma(datum, ioparg);  $ -a- input format.
       3      size  datum(szmax);     $ datum.
       4      size  ioparg(iopsz);    $ io parameter string.
       5      size  i(ps);            $ loop index.
       6      size  n(ps);            $ string capacity of datum.
       7      size  sz(ps);           $ datum size.
       8
       9      access ions;
      10
      11      get_iop = ioparg;
      12      get_fc = 1;
      13      sz = iop_sz ioparg;
      14
      15 .+ifsa_env.   $ bypass use of gcb if no streaming, edit mode.
      16      if  (donotbit(filenow))  return;
      17      size  lm(ps);           $ on if list mode.
      18      size  gw(ps);           $ group width.
      19      size  fw(ps);           $ field width.
      20      size  efw(ps);          $ effective field width.
      21      size  lbp(ps);          $ line buffer pointer.
      22      size  lpb(ps);          $ line position.
      23      size  lsv(ps);          $ linesize value.
      24
      25      $   cannot special case string file, as data not in line buffer.
      26      if  (accessv(filenow) = access_string)  go to notspecial;
      27
      28      lm = iop_lm get_iop;  if  (lm)  go to notspecial;
      29      gw = iop_gw get_iop;  if  (gw)  go to notspecial;
      30      fw = iop_fw get_iop;
      31      if  ((fw=0) ! ((.sds. fw) > sz))  go to notspecial;
      32      lsv = linesizev(filenow);
      33      lbp = lbptr(filenow);
      34      if  lbp+fw <= lsv+1  then
      35          call 7nifsa$li(iolba, iolborg(filenow), lbp, datum, fw);
      36          lbptr(filenow) = lbp + fw;
      37          return;
      38          end if;
      39 /notspecial/
      40 ..ifsa_env
      41
      42      sz = iop_sz get_iop;
      43      call iget(datum);
      44
      45      if  sz <= (.sl.+.so.)  then  $ if no room for str, get null.
      46          n = 0;
      47      else
      48          n = (sz - (.sl.+.so.)) / cs;
      49          end if;
      50      if  (n > gcbptr)  n = gcbptr;
      51      slen datum = n;
      52      sorg datum = (.sds. n) + 1;
      53      do  i = 1 to n;
      54          .ch. i, datum = gcb(i);
      55          end do;
      56      end subr ifma;
       1 .=member ifmb
       2      subr_getfmt(ifmb, 2);  $ -b- output format.
       3      size  c(cs);            $ character.
       4      size  efw(ps);          $ effective field width.
       5      size  bw(ps);           $ byte width.
       6      size  msb(ps);          $ most significant bit to convert.
       7      size  j(ps);            $ loop index.
       8      size  bv(4);            $ byte from datum.
       9      bw = get_bw;
      10      msb = gcbptr * bw;
      11      if  (msb > sz)  msb = sz;
      12
      13      do  i = 1 to msb by bw;
      14          bv = gcb(gcbptr - i/bw);
      15      $   can do full byte unless near end or would cross word boundary.
      16 .+wsm3   if  (i+bw-1) <= sz  then
      17 .-wsm3   if  ((i+bw-1)<=sz) & ((i+bw-2)/ws = (i-1)/ws)  then
      18              .f. i, bw, datum = bv;
      19          else  $ if near end of datum, get bit by bit.
      20              do  j = 0 to bw-1;
      21                  .f. i+j, 1, datum = .f. j+1, 1, bv ;
      22                  if ((i+j)=sz)  quit do i;
      23                  end do;
      24              end if;
      25          end do;
      26
      27      end subr ifmb;
       1 .=member ifme
       2 .-fp.
       3      subr ifme(datum, ioparg);  $ ifme fatal if fp not supported.
       4      size  datum(szmax), ioparg(iopsz);
       5      call ltlfin(1, 1008);  $ floating point not supported.
       6      end subr ifme;
       7 .+fp.
       8      subr_getfmt(ifme, 3);  $ -e- and -f- input formats.
       9      $   get floating point constant.  iget verifies correct structure.
      10      size  dw(ps);           $ decimal width.
      11      real  rv;               $ real value.
      12
      13      dw = iop_dw ioparg;     $ get decimal width.
      14      $  if field given and no point or exponent in field, adjust expone
      15      if  gcb(gcbptr+3) > 0  then  $ if point given, scale value if need
      16          get_expval = get_expval - (gcb(gcbptr+3) -1);
      17      elseif  ((dw > 0) & (gcb(gcbptr+4)=0))  then   $ if no point, and
      18          get_expval = get_expval - dw;
      19          end if;
      20      call cefr(rv, gcb, gcbptr, get_expval);
dsx   29      if  gcb(gcbptr+2)  then  $ if overflow or conversion error.
dsx   30          ioerror(filenow, 1, 1);
dsx   31          return;
dsx   32          end if;
      21      .f. 1, ws, datum = rv;
      22      end subr ifme;
      23 ..fp
       1 .=member ifmi
       2      subr_getfmt(ifmi, 5);  $ -i- input format.
       3      size  v(ws);            $ value to convert.
       4      size  fnz(ps);         $ index of first nonzero character.
       5
       6      $   use negative arithmetic to convert in case have two's
       7      $   complement arithmetic.
       8      v = 0;
       9      do  i = 1 to gcbptr;  $ seek nonzero character.
      10          if  gcb(i)  then  $ if nonzero character.
      11              fnz = i;  go to haveval;  end if;
      12          end do;
      13      go to retval;  $ go to return zero value.
      14 /haveval/
      15      v = - gcb(fnz);
      16      do  i = fnz+1 to gcbptr;  $ convert remaining digits.
      17          if  (v < maxnegint/10)  go to oflow;
      18          v = 10 * v;
      19          if  (((v-maxnegint)-gcb(i)) < 0)  go to oflow;
      20          v = v - gcb(i);
      21          end do;
      22      if (gcb(gcbptr+1) = 0)  v = 0 - v;  $ if positive result.
      23 /retval/
      24      .f. 1, ws, datum = v;
      25      return;
      26 /oflow/  $ if overflow during conversion.
      27      ioerror(filenow, 1, 1);  $ conversion error.
      28      return;
      29      end subr ifmi;
       1 .=member ifmr
       2      subr_getfmt(ifmr, 6); $ input -r- format
       3      size  n(ps);            $ number of characters to convert.
       4
       5      n = sz / cs;
       6      if  (gcbptr < n)  n = gcbptr;
       7
       8      do  i = n-1 to 0 by -1;
       9          .f. i*cs +1, cs, datum = gcb(gcbptr-i);
      10          end do;
      11      end subr ifmr;
       1 .=member vnum
       2      subr vnum(ara, araptr, expval);
       3      $   verify structure of numeric constant.
       4      $   on entry:
       5      $       ara(1) to ara(araptr) contains character codes.
       6      $   on exit:
       7      $       ara(1) to ara(araptr) contain integers in range 0 to 9.
       8      $       ara(araptr+1) is zero if value positive, one if negative.
       9                  $       ara(araptr+2) is zero if verification ok.
      10      $       ara(araptr+2) is one if ara does not contain valid
      11      $       constant.
      12      $       ara(araptr+3) indicates presence of decimal point.
      13      $       if  ara(araptr+3) is zero, constant does not contain poin
      14      $       otherwise, ara(araptr+3) is one more than the number of
      15      $       digits which follow the decimal point.
      16      $       of digits following the point.
      17      $       ara(araptr+4) is zero if no exponent field, one if
      18      $           exponent field.
      19      $       if ara(araptr+4) is one, expval is a signed integer giving
      20      $       the exponent value.
      21
      22      size  ara(cs);  dims ara(2);  $ character list.
      23      size  araptr(ps);       $ position in ara.
      24      size  np(ps);           $ new value for araptr.
      25      size  expval(ws);       $ exponent value.
      26      size  i(ps);            $ loop index.
      27      size  c(cs);            $ character code.
      28      size  d(ws);            $ converted code.
      29      size  epos(ps);         $ index of -e- in numeric constant.
      30      size  esign(ps);        $ exponent sign (0=none, 1=+, 2=-).
      31      size  fsign(ps);        $ fraction sign (0=none, 1=+, 2=-).
      32      size  pointpos(ps);     $ position of decimal point.
dsi   85 .+mc size  ctpc(cs);         $ function to get primary case.
      33      np =0;
      34      epos = 0;  esign = 0;  fsign = 0;  expval = 0;
      35      pointpos = 0;
      36      do  i = 1 to araptr;
      37          c = ara(i);
      38          if  (c = 1r )  cont do;
      39          d = digofchar(c);
      40          if  d >= 0 & d <= 9  then  $ if digit.
      41              if  epos  then  $ if in exponent, convert.
      42                  expval = expval*10 + d;
      43                  epos = epos + 1;
      44              else  $ if part of fraction, add to ara.
      45                  np = np + 1;
      46                  ara(np) = d;
      47                  end if;
      48          elseif c = 1r.  then
      49              if (epos)  go to vererr;
      50              pointpos = np + 1;
dsi   86 .-mc     elseif  c = 1re  then
dsi   87 .+mc     elseif  ctpc(c) = 1re  then
      52              if  (epos)  go to vererr;  $ if duplicate -e-.
      53              epos = 1;
      54          elseif  c = 1r+  !  c = 1r-  then  $ if sign.
      55              if  fsign=0 & np=0  then  $ if first sign.
      56                  fsign = 1 + (c = 1r-);
      57              elseif  esign = 0  then  $ if second sign.
      58                  if  epos = 0  then  $ if e not seen, pretend it wa
      59                      epos = 1;
      60                      esign = 1 + (c = 1r-);
      61                  else  $ second sign, check that e came just before
      62                      if  (epos>1)  go to vererr;
      63                      esign = 1 + (c = 1r-);
      64                      end if;
      66                  end if fsign;
dsc   81              else  go to vererr;
      67              end if d;
      68          end do i;
      69      araptr = np;
      70      if  (np=0)  go to vererr;  $ if no digits in constant.
      71      if  pointpos
      72      then  ara(araptr+3) = np + 2 - pointpos;
      73      else  ara(araptr+3) = 0;  end if;
      74      ara(araptr+4)= (epos ^= 0);
      75      if  (esign=2)  expval = 0 - expval;
      76      ara(araptr+1) = (fsign = 2);  $ restore sign code.
      77      ara(araptr+2) = 0;  $ indicate wellformed constant.
      78      return;
      79 /vererr/   $ illformed constant.
      80      ara(araptr+2) = 1;  $ indicate illformed constant.
      81      end subr vnum;
       1 .=member uinp
       2      subr uinp(ara, nwords);  $ unformatted input.
       3      access ions;
       4      size  ara(ws);  dims ara(2);
       5      size  nwords(ws);       $ words to transmit
       6      size ret(ws);      $ return value from -rdrb- primitive -
       7                         $ e-o-f hit, -3 is e-o-i hit.
       8      if (donotbit(filenow)) return;    $ previous error, so do nothing.
       9
      10      if  nwords < 0  then  $ if bad slice spec.
      11          ioerror(filenow, 2, 19);
      12      elseif  nwords = 0  then  $ if null slice.
      13          return;
      14          end if;
      15
      16      $   if user has not acknowledged end encountered, give error.
      17      if  endack(filenow)  then  $ if outstanding request.
      18          ioerror(filenow, 2, 9);
      19          end if;
      20
      21      call rdrwsio(filenow, ret, ara, 1, nwords);
      22
      23      endseenv(filenow) = 0;
      24      if (ret = 0) return;    $ normal return
      25      donotbit(filenow) = 1;
      26
      27      if  ret > 1  then
dsb   62          ioerror(filenow, 2, 7); $ unformatted input transmission failu
      29      elseif  ret = 1  then  $ end of file.
      30          endseenv(filenow) = yes;
      31          end if;
      32
      33      end subr uinp;
       1 .=member uout
       2      subr uout(ara, nwords);  $ unformatted output.
       3      access ions;
       4      size  ara(ws);  dims ara(2);  $ array to write.
       5      size  nwords(ws);       $ words to transmit
       6      size ret(ws);      $ return value from -wtrb- primitive -
       7                         $ 0 is o.k., anything else is system failure.
       8      if (donotbit(filenow)) return;    $ previous error, so do nothing.
       9      if  nwords < 0  then  $ if bad slice spec.
      10          ioerror(filenow, 2, 19);
      11      elseif  nwords = 0  then  $ if null slice.
      12          return;
      13          end if;
      14      call wtrwsio(filenow, ret, ara, 1, nwords);
      15      if  ret  then
dsb   63          ioerror(filenow, 2, 17);
      17          end if;
      18      end subr uout;
       1 .=member ioer
       2      subr ioer(farg, ernov);  $ process io error.
       3      access ions;
       4      size  farg(ps);          $ file number.
       5      size  fileid(ps);
       6      size  lsv(ps);          $ linesize value.
       7      size  lbp(ps);          $ buffer pointer.
       8      size  lbo(ps);          $ buffer origin.
       9      size  i(ps);            $ loop index.
      10      size  ernov(ws); $ errorv setting + 16*error no.
      11      size  errno(ps);  $ error number
      12      size  erlev(ps);     $ error level.
      13      $   erlev=1 for truncation/conversin, 2 for specification, and 3
      14      $   if op.sys. reported transmission failure.
      15      size  ertab(.sds. 36);  $ error message text table.
dsb   64      +*  ioertot = 22 **  $ number of errors with messages.
      17      +*  ioert(n, t) = data ertab(n) = t; **
      18      dims  ertab(ioertot);
      19      ioert(01, 'conversion or truncation error.')
      20      ioert(02, 'invalid file number.')
      21      ioert(03, 'file not connected.')
      22      ioert(04, 'access alone given, not valid.')
      23      ioert(05, 'linesize given, require title.')
      24      ioert(06, 'require title specification.')
      25      ioert(07, 'cannot allocate line buffer.')
      26      ioert(08, 'file not connected for this access.')
      27      ioert(09, 'attempt to read past end.')
      28      ioert(10, 'field width too large.')
      29      ioert(11, 'string access, get from nonstring.')
      30      ioert(12, 'string access, get with bad index.')
      31      ioert(13, 'input transmission failure.')
      32      ioert(14, 'string access, put to nonstring.')
      33      ioert(15, 'string access, put with bad index.')
      34      ioert(16, 'bad control format specification.')
      35      ioert(17, 'output transmission failure.')
      36      ioert(18, 'cannot redefine standard print file.')
      37      ioert(19, 'invalid array slice.')
dsb   65      ioert(20, 'cannot open file.')
dsb   66      ioert(21, 'cannot close file.')
dsb   67      ioert(22, 'cannot rewind file.')
      38
      39
      40      $   must copy file argumennt in case is ostr_file.
      41      fileid = farg;
      42
      43      if  fileid<1 ! fileid>maxfiles  then  $ if invalid file.
      44          endl  textl('fatal error - invalid file number') intl(fileid)
      45          endl
      46          call ltlfin(1,0);
      47          end if;
      48
      49      errno = ernov / 16;
      50      erlev = ernov - 16*errno;
      51
      52      donotbit(fileid) = (errno^=1);
      53      errorv(fileid) = erlev;
      54      $   if conversion or truncation, accept only if ignore level>0.
      55      $   return if error of this level acceptable.
      56      if  (ignorev(fileid) >= erlev)  return;
      57
      58      if  printfileopen = no  then  $ if cannot print message.
      59          call remarkl('cannot open print file.');
      60          call ltlfin(1, 1007);  $ cannot open print file.
      61          end if;
      62
      63        textl('i/o error - program fileid is ');
dsb   68      intl(fileid);
dsb   69      textl(', title is <')  textl(titlev(fileid))  textl('>.')
      65      endl  textl(ertab(errno))  endl
      66
      67      $   if file has line buffer, print it and record number.
      68      lbo = iolborg(fileid);  $ see if origin.
      69      if  lbo  then  $ if origin, print line
      70          textl('near line') intlp((linenum(fileid)),7)
      71          textl(' in file') intl(fileid)  endl
      72          lsv = linesizev(fileid);
      73          do  i = 1 to iolblen(fileid);
      74              wordl(iolba(lbo+i-1));  end do;
      75          endl
      76          lbp = lbptr(fileid);
      77          if  lbp>1 & lbp<=lsv  then  $ mark position of line pointer.
      78              do  i = 1 to lbp-1;  charl(1r-); end do;
      79              charl(1r$);  $ mark line pointer position.
      80              endl
      81              end if;
      82          end if;
      83
      84 $    debug printout trace if error detected
      85 .+prfi  call prfi(fileid,'io error detected');
      86      endl
      87      $   here if fatal error.
      88      call ltlfin(1, 1300+errno);  $ fatal io error.
      89      end subr ioer;
       1 .=member endlio
       1 .=member blds
       2 .-defenv_ss.
       3 /*
       4 string primitives
       5
       6 author -  d. shields  (nyu-cims)  02-aug-79
       7
       8 this code describes and provides an initial implementation of a
       9 set of string search primitives based in part on those of snobol4
      10 and using the implementation method of various spitbol implementations.
      11 the basic idea is to build 'string sets' which are represented as
      12 one-bit fields in a table indexed by character code.  the operation
      13 to determine if a character is in a set involves indexing the table
      14 by the code and then anding with the appropriate mask.
      15 the primitives should admit an implementation substantially more
      16 efficient than the provided little implementation on most machines.
      17
      18 anyc(c, ss)        match any character in string set ss
      19 anys(s, sp, ss)    match any character in string set ss
      20 blds(s, ss)        build string set from string s
      21 brkc(s, sp, c)     break to character
      22 brks(s, sp, ss)    break to character in string set ss
      23 ctlc(s)            convert character to lower case
      24 ctuc(s)            convert character to upper case
      25 nayc(c, ss)        match any character not in character set ss
      26 nays(s, sp, ss)    match any character not in character set ss
      27 rbrc(s, sp, c)     right break to character c
      28 rbrs(s, sp, ss)    right break to character in string set ss
      29 rpld(s1, s2)       define replacement string for rple
      30 rple(s)            execute replacement
      31 rspc(s, sp, c)     right span character
      32 rsps(s, sp, ss)    right span to character in string set ss
      33 spnc(s, sp, c)     span character
      34 spns(s, sp, ss)    span characters in string set ss
      35 stlc(s)            convert string to lower case
      36 stuc(s)            convert string to upper case
      37
      38  pre-assigned string sets
      39    1 1b'000001' ss_blank   blank
      40    2 1b'000010' ss_separ   separators (blank, tab, form feed)
      41    4 1b'000100' ss_digit   digits 0..9
      42    8 1b'001000' ss_ucltr   upper case letters a..z
      43   16 1b'010000' ss_lcltr   lower case letters a..z (if available)
      44   32 1b'100000' ss_break   break (underline) character '_'
      45
      46  ss_separ includes blank as well as any other characters which
      47  by usual practice are considered equivalent to blank for separating
      48  symbols. for ascii environments, the separators include horizontal
      49  tab and form feed.
      50
      51  support up to 16 string sets
      52
      53
      54 */
      55
      56      $   ss_sz is number of string sets supported. this need be no more
      57      $   16 for assembly language implementations, but is ws for the li
      58      $   implementation.
      59      +*  ss_sz = ws **  $ number of string sets supported.
      60
      61      +*  nchars =  $ number of characters in character set.
      62          $ assume cs=6 or cs=8 or cs=9
      63          ((cs=8)*256 + (cs=6)*64 + (cs=9)*512)
      64          **
      65
      66      $   codes for pre-defined string sets.
      67
      68      +*  ss_blank = 1b'000001' **
      69      +*  ss_separ = 1b'000010' **
      70      +*  ss_digit = 1b'000100' **
      71      +*  ss_ucltr = 1b'001000' **
      72      +*  ss_lcltr = 1b'010000' **
      73      +*  ss_break = 1b'100000' **
      74
      75       subr blds(s, sma);  $ build string set.
      76 $     build string set for string s
      77 $     which can be accessed by string mask sma.
      78      nameset ssns;  $ nameset for string search functions
      79      size  rpltab(cs);           $ translate table
      80      dims  rpltab(nchars);
      81      size  sstab(ss_sz);   $  string search table.
      82      dims  sstab(nchars);
dsc   82 .+s10.  $ initialize sstab for s10 (9 bit ascii)
      84      data sstab =
dsc   83          0(9), ss_separ /* tab */, 0(2), ss_separ /* form feed */,
dsc   84          0(19), ss_blank ! ss_separ, 0(15), ss_digit(10), 0(7),
dsc   85          ss_ucltr(26), 0(4), ss_break, 0, ss_lcltr(26), 0(5), 0(384);
      87 ..s10
      88 .+s11. $ initialize sstab for s11 (8 bit ascii)
      89      data sstab =
      90          0(9), ss_separ /* tab */, 0(2), ss_separ /* form feed */,
      91          0(19), ss_blank ! ss_separ, 0(15), ss_digit(10), 0(7),
      92          ss_ucltr(26), 0(4), ss_break, 0, ss_lcltr(26), 0(5), 0(128);
      93 ..s11
      94 .+s32. $ initialize sstab for s32 (8 bit ascii)
      95      data sstab =
      96          0(9), ss_separ /* tab */, 0(2), ss_separ /* form feed */,
      97          0(19), ss_blank ! ss_separ, 0(15), ss_digit(10), 0(7),
      98          ss_ucltr(26), 0(4), ss_break, 0, ss_lcltr(26), 0(5), 0(128);
      99 ..s32
     100 .+s37. $ initialize sstab for s37 (8 bit ebcdic)
     101      data sstab =
dsbb   2          0(5), ss_separ /* tab */, 0(6), ss_separ /* form feed */,
     103          0(51), ss_blank ! ss_separ, 0(44), ss_break, 0(18),
dsbb   3          0(1), ss_lcltr(9), 0(7), ss_lcltr(9), 0(8), ss_lcltr(8),
     105          0(22), 0, ss_ucltr(9), 0(7), ss_ucltr(9), 0(8), ss_ucltr(8),
     106          0(6), ss_digit(10), 0(6);
     107 ..s37
utsa 135 .+s47. $ initialize sstab for s47 (8 bit ascii)
utsa 136      data sstab =
utsa 137          0(9), ss_separ /* tab */, 0(2), ss_separ /* form feed */,
utsa 138          0(19), ss_blank ! ss_separ, 0(15), ss_digit(10), 0(7),
utsa 139          ss_ucltr(26), 0(4), ss_break, 0, ss_lcltr(26), 0(5), 0(128);
utsa 140 ..s47
     108 .+s66.  $ initialize sstab for s66
     109      data sstab =
     110          0,
     111          ss_ucltr(26), $ alphabetics
     112          ss_digit(10), $ numerics
     113          0(8),
     114          ss_blank ! ss_separ, $ blank (the only separator)
     115          0(7),
     116          ss_break, $ break (underline)
     117          0(10);  $ remaining characters.
     118 ..s66
     119      end nameset;
     120
     121      size  s(.sds. 72);      $ string
     122      size  sma(ss_sz);       $ string mask argument.
     123      size  sm(ss_sz);        $ copy of argument.
     124      size  c(cs);            $ character
     125      size  v(ps);            $ temporary.
     126      size  i(ps);            $ loop index.
     127
     128 $    initialize if sm is zero.
     129      sm = sma;  $ copy argument.
     130
     131      $   clear existing definition.
     132
     133          do  i = 1 to nchars;
     134              sstab(i) = sstab(i) & (.not.sm);
     135              end do;
     136
     137      do  i = 1 to (.len. s);  $ enter set.
     138          c = .ch. i, s;
     139          sstab(1+c) = sstab(1+c) ! sm;
     140          end do;
     141      end subr blds;
       1 .=member anyc
       2      fnct anyc(c, sm);  $ look for character in string set
       3 $    return one if character c is in string set sm;
       4 $    otherwise return zero.
       5
       6      access ssns;  $ access ss globals.
       7      size  c(cs);           $ character to check.
       8      size  anyc(ws);         $ result.
       9      size  sm(ss_sz);        $ string set mask
      10
      11      anyc = (sm & sstab(1+c)) ^= 0;
      12      end fnct anyc;
       1 .=member anys
       2      fnct anys(s, sp, sm);  $ look for character in string set
       3 $    return one if sp-th character of string s is in string set sm;
       4 $    otherwise return zero.
       5
       6      access ssns;  $ access ss globals.
       7      size  s(.sds. 10);      $ string to search.
       8      size  sp(ps);           $ starting position.
       9      size  anys(ws);         $ result.
      10      size  sm(ss_sz);        $ string set mask
      11
      12      if  (sp<1 ! (sp>(.len.s)))  then  anys = -1; return;  end if;
      13      anys = (sm & sstab(1+(.ch.sp,s))) ^= 0;
      14      end fnct anys;
       1 .=member brkc
       2      fnct brkc(s, sp, ch);  $ break character.
       3 $    return length of longest string of s, starting at sp-th
       4 $    character, which is followed by character ch.
       5 $    the function must find an instance of the break character
       6 $    if a nonnegative result is returned.  the result is the number
       7 $    of characters matched not including the break character.
       8      size  s(.sds. 10);      $ string to search.
       9      size  sp(ps);           $ starting position.
      10      size  sm(cs);           $ break character.
      11      size  brkc(ws);         $ result.
      12      size  i(ps);            $ loop index.
      13      size  si(ps);           $ string index.
      14      size  ch(cs);           $ character argument..
      15      size  c(cs);            $ character temporary.
      16
      17      brkc = -1;
      18      if  (sp<1 ! (sp>(.len.s)))  return;
      19      si = sp;
      20      while  si <= .len. s;
      21          c = .ch. si, s;
      22          if  c=ch  then  $ if break character found.
      23              brkc = si - sp;
      24              quit while;
      25              end if;
      26          si = si + 1;
      27          end while;
      28      end fnct brkc;
       1 .=member brks
       2      fnct brks(s, sp, sm);  $ break string set.
       3 $    return length of longest string of s, starting at sp-th
       4 $    character, which is followed by character in char set sm.
       5 $    the function must find an instance of the break character
       6 $    if a nonnegative result is returned.  the result is the number
       7 $    of characters matched not including the break character.
       8      size  s(.sds. 10);      $ string to search.
       9
      10      access ssns;  $ access ss globals.
      11      size  sp(ps);           $ starting position.
      12      size  sm(ss_sz);        $ string set mask
      13      size  brks(ws);         $ result.
      14      size  i(ps);            $ loop index.
      15      size  si(ps);           $ string index.
      16      size  c(cs);            $ character temporary.
      17
      18      brks = -1;
      19      if  (sp<1 ! (sp>(.len.s)))  return;
      20      si = sp;
      21      while  si <= .len. s;
      22          c = .ch. si, s;
      23          if  sstab(1+(c)) & sm  then  $ if break character found.
      24              brks = si - sp;
      25              quit while;
      26              end if;
      27          si = si + 1;
      28          end while;
      29      end fnct brks;
       1 .=member ctlc
       2      fnct ctlc(c);  $ convert character to lower case
       3      access ssns;
       4      size  c(cs);  $ string to translate
       5      size  ctlc(cs);   $ translated character.
       6
       7      $   just copy argument if not upper case letter.
       8      ctlc = c;
       9      if  ((sstab(1+ctlc) & ss_ucltr) = 0)  return;
      10      $   here to convert known upper case to lower case.
dsc   86 .+s10  ctlc = ctlc + 32;
      11 .+s11  ctlc = ctlc + 32;
      12 .+s32  ctlc = ctlc + 32;
      13 .+s37  ctlc = ctlc - 64;
utsa 141 .+s47  ctlc = ctlc + 32;
      14      end fnct ctlc;
       1 .=member ctuc
       2      fnct ctuc(c);  $ convert character to upper case
       3      access ssns;
       4      size  c(cs);  $ string to translate
       5      size  ctuc(cs);        $ translated character.
       6
       7      $   just copy argument if not lower case letter.
       8      ctuc = c;
       9      if  ((sstab(1+ctuc) & ss_lcltr) = 0)  return;
      10      $   here to convert known lower case to upper case.
dsc   87 .+s10  ctuc = ctuc - 32;
      11 .+s11  ctuc = ctuc - 32;
      12 .+s32  ctuc = ctuc - 32;
      13 .+s37  ctuc = ctuc + 64;
utsa 142 .+s47  ctuc = ctuc - 32;
      14      end fnct ctuc;
       1 .=member nayc
       2      fnct nayc(c, sm);  $ look for character not in string set
       3 $    return one if character c is not in string set sm;
       4 $    otherwise return zero.
       5
       6      access ssns;  $ access ss globals.
       7      size  c(cs);        $ character to check.
       8      size  nayc(ws);         $ result.
       9      size  sm(ss_sz);        $ string set mask
      10
      11      nayc = (sm & sstab(1+c)) = 0;
      12      end fnct nayc;
       1 .=member nays
       2      fnct nays(s, sp, sm);  $ look for character not in string set
       3 $    return one if sp-th character of string s is not in string set sm;
       4 $    otherwise return zero.
       5
       6      access ssns;  $ access ss globals.
       7      size  s(.sds. 10);      $ string to search.
       8      size  sp(ps);           $ starting position.
       9      size  nays(ws);         $ result.
      10      size  sm(ss_sz);        $ string set mask
      11
      12      nays = -1;
      13      if  (sp<1 ! (sp>(.len.s)))  return;
      14      nays = (sm & sstab(1+(.ch.sp,s))) = 0;
      15      end fnct nays;
       1 .=member rbrc
       2      fnct rbrc(s, sp, ch);  $ right break character
       3 $    return length of longest string of s, starting at sp-th
       4 $    character, which is preceded by character ch.
       5 $    the function must find an instance of the break character
       6 $    if a nonnegative result is returned.  the result is the number
       7 $    of characters matched not including the break character.
       8      size  s(.sds. 72);      $ string to search.
       9      size  sp(ps);           $ starting position.
      10      size  ch(cs);           $ character argument..
      11      size  rbrc(ws);         $ result.
      12      size  i(ps);            $ loop index.
      13      size  si(ps);           $ string index.
      14      size  c(cs);            $ character temporary.
      15
      16      rbrc = -1;
      17      if  (sp<1 ! (sp>(.len. s)))    return;
      18      si = sp;
      19      while  si >= 1;
      20          c = .ch. si, s;
      21          if  c=ch  then  $ if break character found.
      22              rbrc = sp - si;
      23              quit while;
      24              end if;
      25          si = si - 1;
      26          end while;
      27      end fnct rbrc;
       1 .=member rbrs
       2      fnct rbrs(s, sp, sm);  $ right break string set.
       3 $    return length of longest string of s, starting at sp-th
       4 $    character, which is preceded by character in char set sm.
       5 $    search from right to left.
       6 $    the function must find an instance of the break character
       7 $    if a nonnegative result is returned.  the result is the number
       8 $    of characters matched not including the break character.
       9
      10      access ssns;  $ access ss globals.
      11      size  s(.sds. 72);      $ string to search.
      12      size  sp(ps);           $ starting position.
      13      size  sm(ss_sz);        $ string set mask
      14      size  rbrs(ws);         $ result.
      15      size  i(ps);            $ loop index.
      16      size  si(ps);           $ string index.
      17      size  c(cs);            $ character temporary.
      18
      19      rbrs = -1;
      20      if  (sp<1 ! (sp>(.len. s)))  return;
      21      si = sp;
      22      while  si >= 1;
      23          c = .ch. si, s;
      24          if  sstab(1+(c)) & sm  then  $ if break character found.
      25              rbrs = sp - si;
      26              quit while;
      27              end if;
      28          si = si - 1;
      29          end while;
      30      end fnct rbrs;
       1 .=member rpld
       2      fnct rpld(s1, s2);  $ define replacement string
       3 $    define replacement string for subsequent use by rple.
       4 $    strings s1 and s2 must have the same nonzero length, else
       5 $    rpld returns failure. otherwise, the i-th character or
       6 $    s1 is to be translated to the i-th character of s2.
       7      size  s1(.sds. 72);  $ source string.
       8      size  s2(.sds. 72);  $ target string.
       9      size  rpld(ws);      $ function value.
      10      size  i(ps);         $ loop index.
      11      size  l(ps);         $ string length.
      12      access ssns;
      13      l = .len. s1;
      14      rpld = -1;
      15      if  (l ^= .len. s2)  return; $ if lengths differ.
      16      do  i = 1 to nchars;  $ default is identity transformation.
      17          rpltab(i-1) = i;
      18          end do;
      19      if  (l=0)  return;  $ if lengths zero.
      20      do  i = 1 to l;
      21          rpltab(1+(.ch. i, s1)) = .ch. i, s2;
      22          end do;
      23      rpld = 0;
      24      end fnct rpld;
       1 .=member rple
       2      subr rple(s);  $ translate string
       3 $    translate string s according to translation table last
       4 $    established by rpld.
vaxa  15      access ssns;  $ access ss globals.
       5      size  s(.sds. 72);
       6      size  i(ps);      $ loop index.
       7      do  i = 1 to .len. s;
       8          .ch. i, s = rpltab(1+(.ch. i, s));
       9          end do;
      10      end subr rple;
       1 .=member rspc
       2      fnct rspc(s, sp, ch);  $ right span character
       3 $    return length of longest string of s, starting at sp-th
       4 $    character, which consists of character ch.
       5 $    search from right to left.
       6 $    the search must find at least one instance of the character
       7 $    if a nonnegative result is returned.
       8      size  s(.sds. 10);      $ string to search
       9      size  sp(ps);           $ starting index
      10      size  ch(cs);           $ span character.
      11      size  rspc(ws);         $ result.
      12      size  i(ps);            $ loop index.
      13      size  si(ps);           $ string index.
      14      size  c(cs);            $ character temporary.
      15
      16      if  (sp<1 ! sp>(.len. s)) then  rspc = -1;  return;  end if;
      17      si = sp;
      18      while  si >= 1;
      19          c = .ch. si, s;
      20          if  (c^=ch)  quit while;  $ if end of span.
      21          si = si - 1;
      22          end while;
      23      rspc = sp - si;  $ return length.
      24      if  (rspc=0)  rspc = -1;  $ fail if no characters matched.
      25      end fnct rspc;
       1 .=member rsps
       2      fnct rsps(s, sp, sm);  $ right span string set
       3 $    return length of longest string of s, starting at sp-th
       4 $    character, which consists of characters in string mask sm.
       5 $    search from right to left.
       6 $    the search must find at least one instance of a character
       7 $    in the specified string set if a nonnegative result is returned.
       8
       9      access ssns;  $ access ss globals.
      10      size  s(.sds. 10);      $ string to search
      11      size  sp(ps);           $ starting index
      12      size  sm(16);           $ string set.
      13      size  rsps(ws);         $ result.
      14      size  i(ps);            $ loop index.
      15      size  si(ps);           $ string index.
      16      size  c(cs);            $ character temporary.
      17
      18      if  (sp<1 ! sp>(.len. s)) then  rsps = -1;  return;  end if;
      19      si = sp;
      20      while  si >= 1;
      21          c = .ch. si, s;
      22          if  ((sstab(1+(c))&sm)=0)  quit while;  $ if end of span.
      23          si = si - 1;
      24          end while;
      25      rsps = sp - si;  $ return length.
      26      if  (rsps=0)  rsps = -1;  $ fail if no characters matched.
      27      end fnct rsps;
       1 .=member spnc
       2      fnct spnc(s, sp, ch);  $ span character
       3 $    return length of longest string of s, starting at sp-th
       4 $    character, which consists of character ch.
       5 $    the search must find at least one instance of the character
       6 $    if a nonnegative result is returned.
       7      size  s(.sds. 10);      $ string to search
       8      size  sp(ps);           $ starting index
       9      size  ch(cs);           $ span character.
      10      size  spnc(ws);         $ result.
      11      size  i(ps);            $ loop index.
      12      size  si(ps);           $ string index.
      13      size  c(cs);            $ character temporary.
      14
      15      if  (sp<1 ! sp>(.len. s)) then  spnc = -1;  return;  end if;
      16      si = sp;
      17      while  si <= .len. s;
      18          c = .ch. si, s;
      19          if  (c^=ch)  quit while;  $ if end of span.
      20          si = si + 1;
      21          end while;
      22      spnc = si - sp;  $ return length.
      23      if  (spnc=0)  spnc = -1;  $ fail if no characters matched.
      24      end fnct spnc;
       1 .=member spns
       2      fnct spns(s, sp, sm);  $ span string set
       3 $    return length of longest string of s, starting at sp-th
       4 $    character, which consists of character in string set sm.
       5 $    the search must find at least one instance of a character
       6 $    in the specified string set if a nonnegative result is returned.
       7
       8      access ssns;  $ access ss globals.
       9      size  s(.sds. 10);      $ string to search
      10      size  sp(ps);           $ starting index
      11      size  sm(16);           $ string set.
      12      size  spns(ws);         $ result.
      13      size  i(ps);            $ loop index.
      14      size  si(ps);           $ string index.
      15      size  c(cs);            $ character temporary.
      16
      17      if  (sp<1 ! sp>(.len. s)) then  spns = -1;  return;  end if;
      18      si = sp;
      19      while  si <= .len. s;
      20          c = .ch. si, s;
      21          if  ((sstab(1+(c))&sm)=0)  quit while;  $ if end of span.
      22          si = si + 1;
      23          end while;
      24      spns = si - sp;  $ return length.
      25      if  (spns=0)  spns = -1;  $ fail if no characters matched.
      26      end fnct spns;
       1 .=member stlc
       2      subr stlc(s);  $ convert string to lower case.
       3      size  s(.sds. 72);  $ string to convert
       4      size  ctlc(cs);  $ convert character to lower case.
       5      size  i(ps);  $ loop index.
       6
       7      do  i = 1 to .len. s;
       8          .ch. i, s = ctlc((.ch. i, s));
       9          end do;
      10      end subr stlc;
       1 .=member stuc
       2      subr stuc(s);  $ convert string to upper case.
       3      size  s(.sds. 72);  $ string to convert
       4      size  ctuc(cs);  $ convert character to upper case.
       5      size  i(ps);  $ loop index.
       6
       7      do  i = 1 to .len. s;
       8          .ch. i, s = ctuc((.ch. i, s));
       9          end do;
      10      end subr stuc;
      11 ..defenv_ss
       1 .=member endltl
       1 .=member io16
dsx   33 .+s40.
       3      subr ltlini( dummy ) ;
       4      $ initialize the little system
       5
       6      size dummy( ws ) ;
       7      call ltlsio ; $ intialize lower level
       8      call ltllio( 0 ) ;
       9      return ;
      10      end subr ltlini;
      11
      12
      13
      14      subr ltlfin( a , b ) ;
      15      size a(ws), b(ws);
      16
      17      call ltllio(1) ;  $ terminate i/o, flush buffers
      18
      19      end subr ltlfin;
      20
      21
      22
      23      subr putf;
      24      $ honeywell procedure to output file 2
      25
      26      access ions ;
      27
      28      call putwsio( 2 , ostr_rc , iolba , iolborg(2) , lbptr(2)-1 ) ;
      29
      30      end subr putf ;
      31
      32
      33
      34      subr ioer(fileid, ernov); $ error processor 1
      35      access ions;
      36      /*  process io error -errno-.  error is fatal unless -ignorev-
      37          of fileid is 2. */
      38      size  fileid(ps);
      39      size  ernov(ws); $ errorv setting + 16*error no.
      40      size  errno(ps);  $ error number
      41
      42      errno = ernov / 16;
      43
      44      donotbit(fileid) = (errno^=10);
      45      errorv(fileid) = ernov - 16*errno;
      46      if  (errno = 10)  return; $ no message if conv, trunc.
      47
      48      size m(.sds. 24);
      49      data m = 'i/o error    on file   ' ;
      50      .ch. 11 , m = errno/10 + 1r0 ;
      51      .ch. 12 , m = mod(errno , 10) + 1r0 ;
      52      .ch. 22 , m = fileid/10 + 1r0 ;
      53      .ch. 23 , m = mod(fileid , 10) + 1r0 ;
      54      call crlf ;  call twch( m ) ;  call crlf ;
      55      $ error printed
      56
      57      end subr ioer;
dsw   44 ..s40
       1 .=member begmul
       2 $    we now define the multi-word support procedures.
       3 $
       4      $   protected names of multiword procedures.
       5      +*  addmw = 7niadd$mw **
       6      +*  andmw = 7nband$mw **
       7      +*  beqmw = 7nbequ$mw **
dsx   34      +*  bnemw = 7nbneq$mw **
       8      +*  bgemw = 7nbgeq$mw **
blea   1      +*  bltmw = 7nbles$mw **
       9      +*  casmw = 7ncasi$mw **
      10      +*  catmw = 7nccat$mw **
      11      +*  ceqmw = 7ncequ$mw **
      12      +*  cexmw = 7ncext$mw **
      13      +*  cinmw = 7ncind$mw **
      14      +*  divmw = 7nidiv$mw **
      15      +*  easmw = 7neasi$mw **
      16      +*  eexmw = 7neext$mw **
      17      +*  ermwns = 7nermw$ns **  $ nameset for multiword errors.
      18      +*  errmw = 7neror$mw **
      19      +*  ersmw = 7neros$mw **
      20      +*  fbtmw = 7nbfir$mw **
      21      +*  iormw = 7nbior$mw **
      22      +*  mulmw = 7nimul$mw **
      23      +*  notmw = 7nbnot$mw **
      24      +*  nbtmw = 7nbnum$mw **
      25      +*  submw = 7nisub$mw **
      26      +*  vcsmw = 7nvstr$mw **
      27      +*  xormw = 7nbxor$mw **
      28      +*  emagn = .f.1,(ws-2),**  $ extract magnitude of arith item
      29      +*  erest = .f.(ws-1),2, **  $ extract rest of arithmetic item
      30      +*  ehichunk = $ extracts high order chunk of word
      31         .f. ws/2, ws/2-1, **
      32
      33      +*  elochunk = $ extract low order chunk of word
      34               $ (used by multiword procedures)
      35          .f. 1, ws/2-1, **
      36
      37      +*  ehibint = $ extracts high order bits of integer
      38          .f. ws/2, ws/2, **
      39
       1 .=member errmw
       2      subr errmw(n);  $  error procedure for multi-word procedures
       3      $   process error detected by multiword procedures.
       4      nameset ermwns;
       5          size  xopern(ws);   $ error number.
       6          size  xopsorg(ws);  $ sorg value if trouble with string.
       7          size  xopslen(ws);  $ slen value if trouble with string.
       8          end nameset;
       9      size  n(ws);
      10 .+mwcc.
      11      size  k(ps);
      12 ..mwcc
      13 $
      14 $    this procedure is called when multi-word procedures detect error.
      15 $    negative argument indicates error in compiler, which generated
      16 $    bad call; postiive argument values indicate error in user-
      17 $    supplied values.
      18 .+mwcc.
      19      if  n < 0 then
      20          k = - n;
      21          endl
      22          textl(' system error - compiler generated bad call')
      23          textl(' to multi-word procedure.')
      24          go to errproc;
      25          end if;
      26 ..mwcc
      27      endl textl('error in multi-word calculation') endl
      28      textl('in construct  ')
      29      +*  pmr(txt) = textl(txt); go to errproc; **
      30      go to u(n) in 1 to 31;
      31
      32
      33 /u( 1)/textl('=.e.p,n,x: p<=0 ! p>(size x)'); go to ernproc;
      34 /u( 2)/textl('=.e.p,n,x: n<=0 ! n>(size x)'); go to ernproc;
      35 /u( 3)/textl('=.e.p,n,x: p and n define field not in x.');
      36          go to ernproc;
      37 /u( 4)/pmr('x+y: x illformed.');
      38 /u( 5)/pmr('x+y: y illformed.');
      39 /u( 6)/pmr('x+y: overflow.');
      40 /u( 7)/pmr('x-y: x illformed.');
      41 /u( 8)/pmr('x-y: y illformed.');
      42 /u( 9)/pmr('x-y: underflow');
      43 /u(10)/pmr('x*y: x illformed.');
      44 /u(11)/pmr('x*y: y illformed.');
      45 /u(12)/pmr('x/y: x illformed.');
      46 /u(13)/pmr('x/y: y illformed.');
      47 /u(14)/pmr('x/y: y = 0');
      48 $ 15 is standard error for illformed character string.
      49 /u(15)/textl('argument not in form of string.'); go to ersproc;
      50 /u(16)/textl('x.cc.y: y not in sds format.'); go to ersproc;
      51 /u(17)/textl('x.in.y: x not in sds format.'); go to ersproc;
      52 /u(18)/textl('x.in.y: y not in sds format.'); go to ersproc;
      53 /u(19)/textl('=.s.p,n,s: p<=0 '); go to ernproc;
      54 /u(20)/textl('=.s.p,n,s: n<0 '); go to ernproc;
      55 /u(21)/pmr('=.s.p,n,s: p and n define substring not in s.');
      56 /u(22)/textl('=.s.p,n,s: s is not in sds format.'); go to ersproc;
      57 /u(23)/textl('.s.p,n,t=s: p<=0 '); go to ernproc;
      58 /u(24)/textl('.s.p,n,t=s: n<0 '); go to ernproc;
      59 /u(25)/textl('.s.p,n,t=s: s is not in sds format.'); go to ersproc;
      60 /u(26)/textl('.s.p,n,t=s: t is not in sds format.'); go to ersproc;
      61 /u(27)/pmr('.s.p,n,t=s: (p+n-1)>(slen t)  (invalid position)');
      62 /u(28)/textl('.e.p,n,t=s: p<=0 ! p>(size t)'); go to ernproc;
      63 /u(29)/textl('.e.p,n,t=s: n<=0 ! n>(size t)'); go to ernproc;
      64 /u(30)/textl('.e.p,n,t=s: (p+n-1)>(size t) (invalid position)');
      65 /u(31)/textl('argument to .seq. or .sne. not char. string.')
      66      go to ersproc;
      67          go to ernproc;
      68 /ernproc/  $ print troublesome value
      69      textl(' unacceptable value =') intl(xopern);
      70      go to errproc;
      71 /ersproc/  $ indicate string parameters
      72      textl(' unacceptable string ')  endl
      73      tintl('origin',xopsorg); tintl(' current length',xopslen);
      74      size  cap(ws);  $ capacity (maximmum slen allowed by sorg)
      75      cap = (xopsorg - ldcs - 1) / cs;
      76      tintl(' capacity',cap) endl
      77      if  (cap*cs+ldcs+1)^= xopsorg  then
      78          textl(' string not aligned on character boundary.'); endl
      79          end if;
      80      if  cap<= 0) ! (wy <= 0))
      15        then call errmw(-1);                $  bad argument to land
      16        end if;
      17 ..mwcc
      18 $    set minof and maxof
      19
      20      if  wx < wy  then  minof = wx;  maxof = wy;
      21                   else  minof = wy;  maxof = wx;  end if;
      22
      23 $    compute low order portion of result
      24
      25      do  i =  1 to  minof;
      26          wordi(i, at) = (wordi(i, ax)) & (wordi(i, ay));
      27          end do;
      28 $
      29 $    zero out high order portion of result
      30 $
      31      do  i =  1+minof to  maxof;
      32          wordi(i, at) = 0;
      33          end do;
      34 $
      35      return;
      36      end subr andmw;
      37 ..defenv_andmw
      38
       1 .=member iormw
       2 .-defenv_iormw.
       3      subr iormw(ax, wxarg, ay, wyarg, at); $  x ! y
       4      access ermwns;
       5      access ermwns;
       6      size  ax(szmax), ay(szmax), at(szmax); $ t = x + y.
       7      size  wxarg(ps), wyarg(ps);  $ words in x, y.
       8      size  wx(ps), wy(ps);   $ words in x, y (working copy).
       9      size  i(ps);            $ loop index.
      10      size  minof(ps);        $ min of wx, wy.
      11
      12      wx = wxarg;  wy = wyarg;
      13 .+mwcc.    $  check for compiler error
      14      if ((wx <= 0) ! (wy <= 0))
      15        then call errmw(-2);                $  bad argument to iormw
      16        end if;
      17 ..mwcc
      18      $   set high order words of result to those of longer argument.
      19      if  wx < wy  then
      20          minof = wx;
      21          do  i = 1+minof to wy;  wordi(i, at) = wordi(i, ay);  end do;
      22      else
      23          minof = wy;
      24          do  i = 1+minof to wx;  wordi(i, at) = wordi(i, ax);  end do;
      25          end if;
      26
      27      do  i = 1 to minof;
      28          wordi(i, at) = (wordi(i,ax)) ! (wordi(i, ay));
      29          end do;
      30      end subr iormw;
      31 ..defenv_iormw
      32
       1 .=member xormw
       2 .-defenv_xormw.
       3      subr xormw(ax, wxarg, ay, wyarg, at); $  x .exor. y
       4      access ermwns;
       5      size  ax(szmax), ay(szmax), at(szmax); $ t = x .exor. y.
       6      size  wxarg(ps), wyarg(ps);  $ words in x, y.
       7      size  wx(ps), wy(ps);   $ words in x, y (working copy).
       8      size  i(ps);            $ loop index.
       9      size  minof(ps);        $ min of wx, wy.
      10
      11      wx = wxarg;  wy = wyarg;
      12 .+mwcc.    $  check for compiler error
      13      if ((wx <= 0) ! (wy <= 0))
      14        then call errmw(-3);                $  bad argument to exor
      15        end if;
      16 ..mwcc
      17      $   set high order words of result to those of longer argument.
      18      if  wx < wy  then
      19          minof = wx;
      20          do  i = 1+minof to wy;  wordi(i, at) = wordi(i, ay);  end do;
      21      else
      22          minof = wy;
      23          do  i = 1+minof to wx;  wordi(i, at) = wordi(i, ax);  end do;
      24          end if;
      25
      26      do  i = 1 to minof;
      27          wordi(i, at) = (wordi(i,ax)) .exor. (wordi(i, ay));
      28          end do;
      29      end subr xormw;
      30 ..defenv_xormw
      31
       1 .=member notmw
       2 .-defenv_notmw.
       3      subr notmw(ax, bxarg, at);                 $  ^ x
       4      access ermwns;
       5      size  ax(szmax);        $ argument.
       6      size  bxarg(ps), bx(ps); $ number of bits in x, and local copy.
       7      size  at(szmax);        $ result.
       8      size  i(ps);            $ loop index.
       9      size  wx(ps);           $ words in argument.
      10
      11      bx = bxarg;
      12      wx = (bx -1 ) / ws + 1;
      13 .+mwcc.    $  check for compiler error
      14      if (wx <= 0)
      15        then call errmw(-4);                $  bad argument to notmw
      16        end if;
      17 ..mwcc
      18 $    compute the result
      19
      20      do  i =  1 to  wx;
      21          wordi(i, at) = .not. wordi(i, ax);
      22          end do;
      23
      24      $   clear high order part of last word.
      25      .f. bx+1, wx*ws-bx, at = 0;
      26
      27      end subr notmw;
      28 ..defenv_notmw
       1 .=member eexmw
       2      subr eexmw(axarg, ayarg, az, bzarg, at, btarg); $  t = .e. x, y, z
       3      access ermwns;
       4 $
       5 $
       6      size  axarg(ps), ax(ps);  $ starting position, and copy.
       7      size  ayarg(ps), ay(ps);  $ field length, and copy.
       8      size  bzarg(ps), bz(ps);  $ size of input string.
       9      size  btarg(ps), bt(ps);  $ size of temporary.
      10      size  az(szmax);        $ input.
      11      size  at(szmax);        $ output.
      12      size  lastbit(ps);      $  number of last bit to be moved
      13      size  over(ps);         $  number of bits left over in word
      14      size  wsmover(ps);      $  wordsize minus over
      15      size  overp1(ps);       $  over plus one
      16      size  wsmoverp1(ps);    $  wsmover plus one
      17      size  nwtm(ps);         $  number of words to move
      18      size  swtm(ps);         $  starting word to move
      19      size  temp(ws);         $  temporary
      20      size  i(ps);            $  counter
      21      size  wint(ps);         $  number of words in t
      22      size  nbnm(ps);         $  number of bits not moved
      23      ax = axarg;  ay = ayarg; bz = bzarg;  bt = btarg;
      24 .+mwcc.    $ check for compiler and user errors
      25      if ((bz <= 0) ! (bt <= 0))
      26        then call errmw(-6);                $  bad argument to eexmw
      27        end if;
      28 ..mwcc
      29      if ((ax <= 0) ! (ax > bz))
      30        then xopern =ax; call errmw(1);                 $  bad lbe
      31        end if;
      32      if ((ay < 0) ! (ay > bz))
      33        then xopern=ay; call errmw(2); $  bad eexmw user arg two
      34        end if;
      35      if  ay  then  lastbit = ax + ay - 1;
      36              else  lastbit = ax;  end if;
      37      if (lastbit > bz)
      38        then xopern=lastbit; call errmw(3); $  bad eexmw user arg
      39        end if;
      40 .+mwcc.    if (ay > bt)
      41        then call errmw(-6);
      42                                             $  bad argument to eexmw
      43        end if;
      44 ..mwcc
      45 $    move z (the data) into t (the result)
      46 $
dsi   88      wint = (bt + (ws-1)) / ws;
      48      nwtm = ay / ws;
      49      swtm = (ax - 1) / ws;
      50      wsmover = ax - (1 + swtm * ws);
      51      if  wsmover = 0  $ if field starts in bit 1 of a word
      52        then                                 $  the fast special case
      53        do i =  1 to  nwtm;
      54          wordi(i, at) = wordi(i + swtm, az);
      55          end do;
      56        do i =  nwtm + 1 to  wint;
      57          wordi(i, at) = 0;
      58          end do;
      59        over = ay - nwtm * ws;
      60        if (over > 0) then
      61          temp = .f. 1, over, (wordi(swtm + nwtm + 1, az));
      62          wordi(nwtm + 1, at) = temp;
      63          end if;
      64        else                                 $  the general case
      65        over = ws - wsmover;
      66        overp1 = over + 1;
      67        wsmoverp1 = wsmover + 1;
      68        do i =  1 to  nwtm;
      69          temp = .f. wsmoverp1, over, (wordi(swtm + i, az));
      70          .f. overp1, wsmover, temp = wordi(swtm + i + 1, az);
      71          wordi(i, at) = temp;
      72          end do;
      73        do i =  1+nwtm to  wint;
      74          wordi(i, at) = 0;
      75          end do;
      76        nbnm = ay - nwtm * ws;
      77        if (nbnm ^= 0) then
      78          if (nbnm < over) then
      79            wordi(nwtm + 1, at) = .f. wsmoverp1, nbnm,
      80                                  (wordi(swtm + nwtm + 1, az));
      81            else
      82            wordi(nwtm + 1, at) = .f. wsmoverp1, over,
      83                                  (wordi(swtm + nwtm + 1, az));
      84            nbnm = nbnm - over;
      85            if (nbnm ^= 0) then
      86              temp = 0;
      87              .f. overp1, nbnm, temp = wordi(swtm + nwtm + 2, az);
      88              wordi(nwtm + 1, at) = wordi(nwtm + 1, at) ! temp;
      89              end if;
      90            end if;
      91          end if;
      92        end if;
      93 $
      94      end subr eexmw;
       1 .=member easmw
       2      subr easmw(axarg, ayarg, az, bzarg, at, btarg); $ .e. x,y,t = z
       3      access ermwns;
       4 $
       5 $
       6      size  axarg(ps), ax(ps);  $ starting position, and copy.
       7      size  ayarg(ps), ay(ps);  $ field length, and copy.
       8      size  bzarg(ps), bz(ps);  $ size of input string.
       9      size  btarg(ps), bt(ps);  $ size of temporary.
      10      size  az(szmax);        $ input.
      11      size  at(szmax);        $ output.
      12      size  lastbit(ps);      $  number of last bit to be moved
      13      size  sworg(ps);        $  source word bit origin in z
      14      size  nba(ps);          $  number of bits available in source wo
      15      size  tworg(ps);        $  target word bit origin in t
      16      size  twd(ws);          $  target word (will be replaced in t)
      17      size  fbtbr(ps);        $  first bit to be replaced in twd
      18      size  lbtbr(ps);        $  last bit to be replaced in twd
      19      size  nbtbr(ps);        $  number of bits to be replaced in twd
      20      size  swd(ws);          $  source word (from z, or perhaps zero)
      21      size  width(ps);        $  number of zero pad bits in source wor
      22      size  nbufsw(ps);       $  number of bits used from source word
      23
      24      ax = axarg;  ay = ayarg;
      25      bz = bzarg;  bt = btarg;
      26 .+mwcc.  $ check for compiler error
      27      if ((bz <= 0) ! (bt <= 0))
      28        then call errmw(-17);               $  bad argument to easmw
      29        end if;
      30 ..mwcc
      31      if  ((ax <= 0) ! (ax > bt))  then
      32          xopern=ax; call errmw(28); $  bad easmw user arg one
      33          end if;
      34      if  ((ay < 0) ! (ay > bt))  then
      35          xopern=ay; call errmw(29); $  bad easmw user arg two
      36          end if;
      37      if  (ay = 0)  return;
      38      lastbit = ax + ay - 1;
      39      if  (lastbit > bt)  then
      40          xopern=lastbit; call errmw(30);
      41            $ bad combination of arguments
      42          end if;                               $  arguments to easmw
      43
      44 $    move z (the data) into t (the target field)
      45
      46      sworg = 1;                             $  initialize delimiters
      47      nba = 0;
      48      tworg = ((ax - 1) / ws) * ws + 1;
      49 $
      50      while (tworg <= lastbit);
      51        twd = .f. tworg, ws, at;
      52        if (tworg < ax)
      53          then fbtbr = 1 + ax - tworg;
      54          else fbtbr = 1;
      55          end if;
      56        if (lastbit < (tworg + ws))
      57          then lbtbr = lastbit + 1 - tworg;
      58          else lbtbr = ws;
      59          end if;
      60        nbtbr = lbtbr + 1 - fbtbr;
      61        while  (nbtbr);
      62          if (nba = 0) then               $  fetch ws source bits
      63            if (sworg) then                  $  from z (or some zero
      64              swd = .f. sworg, ws, az;       $  bits if z has already
      65              sworg = sworg + ws;            $  been exhausted)
      66              if (sworg > bz) then
      67                width = sworg - (1 + bz);
      68                if (width) then
      69                  .f. ws + 1 - width, width, swd = 0;
      70                  end if;
      71                sworg = 0;
      72                end if;
      73              else  swd = 0;
      74              end if;
      75            nba = ws;
      76            end if;                           $  end bit fetch from z
      77          if (nba < nbtbr)
      78            then nbufsw = nba;
      79            else nbufsw = nbtbr;
      80            end if;
      81          .f. fbtbr, nbufsw, twd = .f. ws + 1 - nba, nbufsw, swd;
      82          nba = nba - nbufsw;
      83          nbtbr = nbtbr - nbufsw;
      84          fbtbr = fbtbr + nbufsw;
      85          end while;
      86        .f. tworg, ws, at = twd;             $  replace twd in t
      87        tworg = tworg + ws;
      88        end while;
      89
      90      end subr easmw;
      91
       1 .=member fbtmw
       2 .-defenv_fbtmw.
       3      fnct fbtmw(ax, wxarg);                  $  .fb. x
       4      size  ax(szmax);        $ argument.
       5      size  wxarg(ps), wx(ps); $ words in argument, and copy.
       6      size  fbtmw(ps);        $ function value.
       7      size  i(ps);            $ index.
       8
       9      wx = wxarg;
      10 .+mwcc.    $ check for compiler error
      11      if (wx <= 0)
      12        then call errmw(-7);                $  bad argument to fbtmw
      13        end if;
      14 ..mwcc
      15      fbtmw = 0;
      16      do  i = wx to 1 by -1;
      17          if  wordi(i,ax)  then  fbtmw = i;  quit do;  end if;
      18          end do;
      19      if  fbtmw  then
      20          fbtmw = ws * (fbtmw - 1) + .fb. (wordi(fbtmw, ax));
      21        end if;
      22
      23      end fnct fbtmw;
      24 ..defenv_fbtmw
      25
       1 .=member nbtmw
       2 .-defenv_nbtmw.
       3      fnct nbtmw(ax, wxarg);                  $  .nb. x
       4
       5
       6      size  nbtmw(ps);        $ function value.
       7      size  ax(szmax);        $ argument.
       8      size  wxarg(ps), wx(ps); $ words in argument, and copy.
       9      size  i(ps);            $ index.
      10
      11      wx = wxarg;
      12 .+mwcc.  $    check for compiler error
      13      if (wx <= 0)
      14        then call errmw(-8);                $  bad argument to nbtmw
      15        end if;
      16 ..mwcc
      17      nbtmw = 0;
      18      do  i =  1 to  wx;
      19          nbtmw = nbtmw + .nb. (wordi(i, ax));
      20          end do;
      21      end fnct nbtmw;
      22 ..defenv_nbtmw
      23
       1 .=member beqmw
       2      fnct beqmw(ax, wxarg, ay, wyarg);       $  x = y
       3
       4
       5      size  ax(szmax), ay(szmax);  $ arguments.
       6      size  wxarg(ps), wyarg(ps);  $ words in arguments.
       7      size  wx(ps), wy(ps);   $ words in arguments, working copy.
       8      size  beqmw(1);         $ function value.
       9      size  minof(ps);        $ min of wx, wy.
      10      size  i(ps);            $ loop index.
      11
      12      wx = wxarg;  wy = wyarg;
      13 .+mwcc. $    check for compiler error
      14      if  ((wx <= 0) ! (wy <= 0))  then
      15          call errmw(-9);                $  bad argument to beqmw
      16          end if;
      17 ..mwcc
      18      beqmw = 1;
      19      if (wx < wy)
      20        then minof = wx;
      21        else minof = wy;
      22        end if;
      23
      24 $    one or two of the following three loops will be executed
      25
      26      do i =  1 to  minof;
      27        if (wordi(i, ax) .ex. wordi(i, ay)) then
      28          beqmw = 0;
      29          return;
      30          end if;
      31        end do;
      32      do i =  1 + minof to  wx;
      33        if (wordi(i, ax)) then
      34          beqmw = 0;
      35          return;
      36          end if;
      37        end do;
      38      do i =  1 + minof to  wy;
      39        if (wordi(i, ay)) then
      40          beqmw = 0;
      41          return;
      42          end if;
      43        end do;
      44
      45      end fnct beqmw;
       1 .=member bnemw
       2      fnct bnemw(ax, wxarg, ay, wyarg);       $  x .ne. y
       3
       4
       5      size  ax(szmax), ay(szmax);  $ arguments.
       6      size  wxarg(ps), wyarg(ps);  $ words in arguments.
       7      size  wx(ps), wy(ps);   $ words in arguments, working copy.
       8      size  bnemw(1);         $ function value.
       9      size  minof(ps);        $ min of wx, wy.
      10      size  i(ps);            $ loop index.
      11
      12      wx = wxarg;  wy = wyarg;
      13 .+mwcc. $    check for compiler error
      14      if  ((wx <= 0) ! (wy <= 0))  then
      15          call errmw(-9);                $  bad argument to bnemw
      16          end if;
      17 ..mwcc
      18      bnemw = 0;
      19      if (wx < wy)
      20        then minof = wx;
      21        else minof = wy;
      22        end if;
      23
      24 $    one or two of the following three loops will be executed
      25
      26      do i =  1 to  minof;
      27        if (wordi(i, ax) .ex. wordi(i, ay)) then
      28          bnemw = 1;
      29          return;
      30          end if;
      31        end do;
      32      do i =  1 + minof to  wx;
      33        if (wordi(i, ax)) then
      34          bnemw = 1;
      35          return;
      36          end if;
      37        end do;
      38      do i =  1 + minof to  wy;
      39        if (wordi(i, ay)) then
      40          bnemw = 1;
      41          return;
      42          end if;
      43        end do;
      44
      45      end fnct bnemw;
       1 .=member bgemw
       2      fnct bgemw(ax, wxarg, ay, wyarg);              $  x >= y
       3      size  ax(szmax), ay(szmax);  $ arguments.
       4      size  wxarg(ps), wyarg(ps);  $ words in arguments.
       5      size  wx(ps), wy(ps);   $ words in arguments, working copy.
       6      size  bgemw(1);         $ function value.
       7      size  minof(ps);        $ min of wx, wy.
       8      size  i(ps);            $ loop index.
       9      size  tempx(ws), tempy(ws);  $ temporaries.
      10
      11      wx = wxarg;  wy = wyarg;
      12 .+mwcc. $    check for compiler error
      13      if  ((wx <= 0) ! (wy <= 0))  then
      14          call errmw(-11);    $  bad argument to bgemw
      15          end if;
      16 ..mwcc
      17      if (wx < wy)
      18        then minof = wx;
      19        else minof = wy;
      20        end if;
      21
      22 $    one or two of the following three loops will be executed
      23
      24      do i =  1 + minof to  wx;
      25        if (wordi(i, ax)) then
      26          bgemw = 1;
      27          return;
      28          end if;
      29        end do;
      30      do i =  1 + minof to  wy;
      31        if (wordi(i, ay)) then
      32          bgemw = 0;
      33          return;
      34          end if;
      35        end do;
      36      bgemw = 1;
      37      do  i = minof to 1 by -1;
      38          tempx = wordi(i, ax);
      39          tempy = wordi(i, ay);
      40          if  tempx ^= tempy  then
      41              bgemw = (tempx >= tempy);
      42              return;
      43              end if;
      44          end do;
      45      $   here if items agree, return true.
      46
      47      end fnct bgemw;
       1 .=member bltmw
       2      fnct bltmw(ax, wxarg, ay, wyarg);              $  x < y
       3      size  ax(szmax), ay(szmax);  $ arguments.
       4      size  wxarg(ps), wyarg(ps);  $ words in arguments.
       5      size  wx(ps), wy(ps);   $ words in arguments, working copy.
       6      size  bltmw(1);         $ function value.
       7      size  minof(ps);        $ min of wx, wy.
       8      size  i(ps);            $ loop index.
       9      size  tempx(ws), tempy(ws);  $ temporaries.
      10
      11      wx = wxarg;  wy = wyarg;
      12 .+mwcc. $    check for compiler error
      13      if  ((wx <= 0) ! (wy <= 0))  then
      14          call errmw(-11);    $  bad argument to bltmw
      15          end if;
      16 ..mwcc
      17      if (wx < wy)
      18        then minof = wx;
      19        else minof = wy;
      20        end if;
      21
      22 $    one or two of the following three loops will be executed
      23
      24      do i =  1 + minof to  wx;
      25        if (wordi(i, ax)) then
      26          bltmw = 0;
      27          return;
      28          end if;
      29        end do;
      30      do i =  1 + minof to  wy;
      31        if (wordi(i, ay)) then
      32          bltmw = 1;
      33          return;
      34          end if;
      35        end do;
      36      bltmw = 0;
      37      do  i = minof to 1 by -1;
      38          tempx = wordi(i, ax);
      39          tempy = wordi(i, ay);
      40          if  tempx ^= tempy  then
      41              bltmw = (tempx < tempy);
      42              return;
      43              end if;
      44          end do;
      45      $   here if items agree, return false.
      46
      47      end fnct bltmw;
       1 .=member addmw
       2 .-defenv_addmw.
       3      subr addmw(ax, wxarg, ay, wyarg, at);         $  x + y
       4      access ermwns;
       5      size  ax(szmax), ay(szmax), at(szmax); $ t = x + y.
       6      size  wxarg(ps), wyarg(ps);  $ words in x, y.
       7      size  wx(ps), wy(ps);   $ words in x, y (working copy).
       8      size  i(ps);            $ loop index.
       9      size  minof(ps);        $ min of wx, wy.
      10      size  maxof(ps);        $ max of wx, wy.
      11      size  tempx(ws), tempy(ws);  $ temporaries.
      12      size  carry(1);         $ carry bit.
      13
      14      wx = wxarg;  wy = wyarg;
      15 .+mwcc. $    check for compiler error
      16      if ((wx <= 0) ! (wy <= 0))
      17        then call errmw(-12);               $  bad argument to addmw
      18        end if;
      19 ..mwcc
      20      carry = 0;
      21      if (wx < wy)
      22        then minof = wx;
      23        else minof = wy;
      24        end if;
      25
      26 $    one or two of the following three loops will be executed
      27
      28      do i =  1 to  minof;
      29        tempx = wordi(i, ax);
      30        tempy = wordi(i, ay);
      31        if (erest tempx ^= 0) then
      32          call errmw(4);                    $  bad user arg one to addm
      33          end if;
      34        if (erest tempy ^= 0) then
      35          call errmw(5);                    $  bad user arg two to addm
      36          end if;
      37        tempy = tempx + tempy + carry;
      38        carry = erest tempy;
      39        wordi(i, at) = emagn tempy;
      40        end do;
      41
      42      do i =  1 + minof to  wx;
      43        tempx = wordi(i, ax);
      44        if (erest tempx ^= 0) then
      45          call errmw(4);                    $  bad user arg one to addm
      46          end if;
      47        tempx = tempx + carry;
      48        carry = erest tempx;
      49        wordi(i, at)= emagn tempx;
      50        end do;
      51
      52      do i =  1 + minof to  wy;
      53        tempy = wordi(i, ay);
      54        if (erest tempy ^= 0) then
      55          call errmw(5);                    $  bad user arg two to addm
      56          end if;
      57        tempy = tempy + carry;
      58        carry = erest tempy;
      59        wordi(i, at) = emagn tempy;
      60        end do;
      61
      62      if (carry ^= 0) then
      63        call errmw(6);                      $  overflow in addmw
      64        end if;
      65
      66      end subr addmw;
      67 ..defenv_addmw
       1 .=member submw
       2 .-defenv_submw.
       3      subr submw(ax, wxarg, ay, wyarg, at);    $  x - y
       4      access ermwns;
       5      size  ax(szmax), ay(szmax), at(szmax); $ t = x + y.
       6      size  wxarg(ps), wyarg(ps);  $ words in x, y.
       7      size  wx(ps), wy(ps);   $ words in x, y (working copy).
       8      size  i(ps);            $ loop index.
       9      size  minof(ps);        $ min of wx, wy.
      10      size  tempx(ws), tempy(ws);  $ temporaries.
      11      size  borrow(1);         $ borrow bit.
      12
      13      wx = wxarg;  wy = wyarg;
      14
      15 .+mwcc. $    check for compiler error
      16      if ((wx <= 0) ! (wy <= 0))
      17        then call errmw(-13);               $  bad argument to lsub
      18        end if;
      19 ..mwcc
      20 $    check for certain underflow - the loop may not be executed
      21
      22      do i =  1 + wx to  wy;
      23        if (wordi(i, ay) ^= 0) then
      24          call errmw(9);                    $  underflow in lsub
      25          end if;
      26        end do;
      27
      28 $    try subtracting - we may still underflow
      29
      30      borrow = 0;
      31      do i =  1 to  wx;
      32        tempx = wordi(i, ax);
      33        if (erest tempx ^= 0) then
      34          call errmw(7);                    $  bad user arg one to lsub
      35          end if;
      36        if (i > wy)
      37          then tempy = 0;
      38          else tempy = wordi(i, ay);
      39          if (erest tempy ^= 0) then
      40            call errmw(8);                  $  bad user arg two to lsub
      41            end if;
      42          end if;
      43        tempy = tempy + borrow;
      44        if (tempx >= tempy)
      45          then borrow = 0;
      46          else borrow = 1;
      47          erest tempx = 1;
      48          end if;
      49        wordi(i, at) = tempx - tempy;
      50        end do;
      51
      52      if (borrow = 1) then
      53        call errmw(9);                      $  underflow in lsub
      54        end if;
      55
      56      end subr submw;
      57 ..defenv_submw
       1 .=member mulmw
       2 .-defenv_mulmw.
       3      subr mulmw(ax, wxarg, ay, wyarg, at);    $  x * y
       4      access ermwns;
       5      size  ax(szmax), ay(szmax), at(szmax); $ t = x + y.
       6      size  wxarg(ps), wyarg(ps);  $ words in x, y.
       7      size  wx(ps), wy(ps);   $ words in x, y (working copy).
       8      size  minof(ps);        $ min of wx, wy.
       9      size  tempx(ws), tempy(ws);  $ temporaries.
      10      size  borrow(1);         $ borrow bit.
      11      size  dig1(ws);    $  low order digit of multiplicand word
      12      size  dig2(ws);    $  high order digit of multiplicand word
      13      size  dig3(ws);    $  low order digit of multiplier word
      14      size  dig4(ws);    $  high order digit of multiplier word
      15      size  pp1(ws);     $  partial product (dig1 * dig3)
      16      size  pp2(ws);     $  partial product (dig1*dig4 + dig2*dig3)
      17      size  pp3(ws);     $  partial product (dig2 * dig4)
      18      size  i(ps);       $  counter for multiplicand words
      19      size  j(ps);       $  counter for multiplier words
      20      size  k(ws);       $  counter for product words
      21      size  twd(ws);     $  temporary
      22
      23      wx = wxarg;  wy = wyarg;
      24 $    check for compiler and user errors, then initialize
      25
      26 .+mwcc.      if ((wx <= 0) ! (wy <= 0))
      27        then call errmw(-14);               $  bad argument to lmul
      28        end if;
      29 ..mwcc
      30      do i =  1 to  wx;
      31        if (erest(wordi(i, ax)))
      32          then call errmw(10);              $  bad user arg one to lmul
      33          end if;
      34        end do;
      35      do j =  1 to  wy;
      36        if (erest(wordi(j, ay)))
      37          then call errmw(11);              $  bad user arg two to lmul
      38          end if;
      39        end do;
      40      twd = wx + wy;
      41      do k =  1 to  twd;
      42        wordi(k, at) = 0;                    $  zero the product field
      43        end do;
      44
      45 $    perform multiplication
      46
      47      do i =  1 to  wx;                    $  begin multiplicand loop
      48        twd = wordi(i, ax);
      49        if (twd) then
      50          dig1 = elochunk twd;
      51          dig2 = ehichunk twd;
      52          do j =  1 to  wy;                    $  begin multiplier loop
      53            twd = wordi(j, ay);
      54            if (twd) then
      55              dig3 = elochunk twd;
      56              dig4 = ehichunk twd;
      57              pp1 = dig1 * dig3;
      58              pp2 = dig1 * dig4 + dig2 * dig3;
      59              pp3 = dig2 * dig4;
      60              ehibint pp1 = (ehibint pp1) + (elochunk pp2);
      61              pp3 = pp3 + (ehibint pp2) + (erest pp1);
      62              erest pp1 = 0;
      63              k = i + j;
      64              wordi(k-1, at) = pp1 + wordi(k-1, at);
      65              wordi(k, at) = erest(wordi(k-1, at)) + pp3 + wordi(k, at);
      66              wordi(k-1, at) = emagn(wordi(k-1, at));
      67              wordi(k+1, at) = erest(wordi(k, at)) + wordi(k+1, at);
      68              wordi(k, at) = emagn(wordi(k, at));
      69              end if;
      70            end do;                            $  end multiplier loop
      71          end if;
      72        end do;                                $  end multiplicand loop
      73
      74      end subr mulmw;
      75 ..defenv_mulmw
       1 .=member divmw
       2 .-defenv_divmw.
       3      subr divmw(ax, wxarg, ay, wyarg, at);    $  x / y
       4      access ermwns;
       5      size  ax(szmax), ay(szmax), at(szmax); $ t = x / y.
       6      size  wxarg(ps), wyarg(ps);  $ words in x, y.
       7      size  wx(ps), wy(ps);   $ words in x, y (working copy).
       8      size  i(ps);            $ loop index.
       9      size  middend(ps);  $  start of remainder portion of dividend
      10      size  nswsor(ps);   $  number of significant words in divisor
      11      size  nswdend(ps);  $  number of significant words in dividend
      12      size  fbsor(ps);    $  .fb. wordi(nswsor, divisor)
      13      size  fbdend(ps);   $  .fb. wordi(nswdend, dividend)
      14      size  nsbsor(ws);   $  number of significant bits in divisor
      15      size  nsbdend(ws);  $  number of significant bits in dividend
      16      size  ntshsor(ps);  $  number of times to shift divisor
      17      size  ntshdend(ps); $  number of times to shift dividend
      18      size  nttl(ps);     $  number of times through division loop
      19      size  yeswedid(ws); $  subtract before shifting dividend
      20      size  j(ps);        $  counter
      21      size  t1(ws);       $  temporary
      22      size  t2(ws);       $  temporary
      23      size  t3(ws);       $  temporary
      24
      25 $    the algorithm used here is a software simulation of the division
      26 $    process common to most computer hardware registers.  the divisor
      27 $    or dividend is shifted left to align their first significant bits.
      28 $    then iteratively:  the divisor is subtracted from the high order
      29 $    end of the dividend if it is not greater than that end of the
      30 $    dividend; the dividend is shifted left by one bit, and a one bit
      31 $    or a zero bit is appended to its low order end according to whe-
      32 $    ther subtraction was or was not performed.  when this process has
      33 $    been done a number of times (equal to one plus the difference be-
      34 $    tween the number of significant bits in the original divisor and
      35 $    dividend) then the quotient appears in the low order end of what
      36 $    was the dividend and the remainder (which we do not use in this
      37 $    particular application) appears in the high order end.
      38
      39 $    macro for left shift of long integer by one bit.  yeswedid is the
      40 $    bit appended to the low order end.  this macro is always nested
      41 $    in a loop of the form do i =  - to  -; .... end do;
      42
      43      +*ldshift(nbrofwds, whereitis) =
      44        do j =  1 to  nbrofwds;
      45          .f. 2, (ws-1), yeswedid = wordi(j, whereitis);
      46          if (j = nbrofwds)
      47            then wordi(j, whereitis) = yeswedid;
      48            else wordi(j, whereitis) = .f. 1, (ws-2), yeswedid;
      49            yeswedid = .f. (ws-1), 1, yeswedid;
      50            end if;
      51          end do **
      52
      53 $    macro for end-off right shift of long integer by one bit.  this
      54 $    macro is always nested in a loop of form
      55 $            do i =  - to  -; .... end do;
      56
      57      +*rdshift(nbrofwds, whereitis) =
      58        t1 = .f. 2, (ws-1), whereitis;
      59        do j =  2 to  nbrofwds;
      60          t2 = wordi(j, whereitis);
      61          .f. (ws-2), 1, t1 = .f. 1, 1, t2;
      62          wordi(j - 1, whereitis) = t1;
      63          t1 = .f. 2, (ws-1), t2;
      64          end do;
      65        wordi(nbrofwds, whereitis) = t1**
      66
      67 $    check for bad arguments, move dividend to quotient, initialize
      68 $    some of the delimiters as defined in the size statements.
      69 .+mwcc.      if ((wx <= 0) ! (wy <= 0))
      70        then call errmw(-15);               $  bad argument to ldiv
      71        end if;
      72 ..mwcc
      73      nswdend = 0;
      74      fbdend = 0;
      75      do i =  1 to  wx;
      76        t1 = wordi(i, ax);
      77        wordi(i, at) = t1;                   $  initialize quotient
      78        if (t1) then
      79          nswdend = i;
      80          fbdend = t1;
      81          if (erest t1) then
      82            call errmw(12);                 $  bad user arg one to ldiv
      83            end if;
      84          end if;
      85        end do;
      86
      87      fbdend = .fb. fbdend;
      88      nswsor = 0;
      89      fbsor = 0;
      90      do i =  1 to  wy;
      91        t1 = wordi(i, ay);
      92        if (t1) then
      93          nswsor = i;
      94          fbsor = t1;
      95          if (erest t1) then
      96            call errmw(13);                 $  bad user arg two to ldiv
      97            end if;
      98          end if;
      99        end do;
     100
     101      fbsor = .fb. fbsor;
     102      if (nswsor)
     103        then nsbsor = fbsor + (nswsor - 1) * (ws-2);
     104        else call errmw(14);                $  zero divisor to ldiv
     105        end if;
     106
     107 $    test for trivial cases and complete the initialization
     108
     109      if (nsbsor = 1)                     $  divisor = one
     110        then return;
     111        end if;
     112      if (nswdend >= nswsor)
     113        then nsbdend = fbdend + (nswdend - 1) * (ws-2);
     114        else nsbdend = 0;
     115        end if;
     116
     117      if (nsbdend = nsbsor) then          $  compare divisor:dividend
     118        do i =  1 to  nswsor;
     119          t2 = wordi(i, ax);
     120          t3 = wordi(i, ay);
     121          if (t2 > t3) then
     122            nsbdend = 1;
     123            end if;
     124          if (t2 < t3) then
     125            nsbdend = 0;
     126            end if;
     127          end do;
     128        end if;
     129
     130      if (nsbdend <= nsbsor) then          $  quotient = zero or one
     131        do i =  1 to  nswdend;
     132          wordi(i, at) = 0;
     133          end do;
     134        if (nsbdend) then
     135          wordi(1,at) = 1;
     136          end if;
     137        return;
     138        end if;
     139
     140      middend = nswdend - nswsor;
     141      if (fbdend > fbsor)
     142        then ntshdend = 0;
     143        ntshsor = fbdend - fbsor;
     144        else ntshsor = 0;
     145        ntshdend = fbsor - fbdend;
     146        end if;
     147      nttl = 1 + nsbdend - nsbsor;
     148      yeswedid = 0;
     149
     150      do i =  1 to  ntshdend;                   $  shift dividend left
     151        ldshift(nswdend, at);                $   (at most one of these
     152        end do;                           $   two loops is executed)
     153      do i =  1 to  ntshsor;                    $  shift divisor left
     154        ldshift(nswsor, ay);
     155        end do;
     156
     157 $    initialization is complete - begin division loop
     158
     159      do i =  1 to  nttl;
     160        yeswedid = 1;                        $  see whether to subtract
     161        do j =  1 to  nswsor;             $  and set yeswedid to one
     162          t1 = wordi(nswdend + 1 - j, at);   $  or zero accordingly
     163          t2 = wordi(nswsor + 1 - j, ay);
     164          if (t1 < t2) then
     165            yeswedid = 0;
     166            quit do;
     167            end if;
     168          if (t1 > t2) then
     169            quit do;
     170            end if;
     171          end do;
     172
     173        if (yeswedid) then                   $  subtract divisor from
     174          t3 = 0;                            $  high order end of result
     175          do j =  1 to  nswsor;           $  (use t3 as a borrow bit)
     176            t1 = wordi(middend + j, at);
     177            t2 = wordi(j, ay) + t3;
     178            if (t2 > t1)
     179              then  t3 = 1;
     180              erest t1 = 1;
     181              else  t3 = 0;
     182              end if;
     183            wordi(middend + j, at) = t1 - t2;
     184            end do;                            $  end subtract loop
     185          end if;
     186
     187        ldshift(nswdend, at);                $  shift left one bit and
     188        end do;                                $  append yeswedid
     189
     190 $    division has been accomplished in that the quotient resides in
     191 $    the nttl low order bits of at (exclusive of sign and carry bits).
     192 $    for future reference, we note that the remainder (which we will
     193 $    summarily zero out) has nsbsor bits, and that its high order bit
     194 $    is the carry bit of word nswdend of at.  the remainder proceeds
     195 $    from this peculiar origin to the right, skipping all sign (i.e.
     196 $    leftmost) bits of its component words, and skipping all other
     197 $    carry (i.e. next to leftmost) bits of its component words.  thus
     198 $    the quotient and remainder portions of the result never overlap,
     199 $    but will have ntshdend superfluous zero bits between them.  to
     200 $    avoid messing up our inputs, we start the termination process by
     201 $    executing ntshsor end-off one bit right shifts of the divisor.  we
     202 $    have made the one bit right shift into a macro (even though we use
     203 $    it only once in this procedure) because it will be useful in deali
     204 $    with the remainder if little ever gets a mod operator.
     205
     206      do i =  1 to  ntshsor;               $  shift divisor right to
     207        rdshift(nswsor, ay);                 $  restore it - this loop
     208        end do;                                $  may not be executed
     209      t1 = nttl / (ws-2);
     210      t2 = nttl - t1 * (ws-2);
     211      if (t2) then
     212        t1 = t1 + 1;
     213        wordi(t1, at) = .f. 1, t2, (wordi(t1, at));
     214        end if;
     215      do i =  t1 + 1 to  nswdend;          $  zero out the remainder
     216        wordi(i, at) = 0;
     217        end do;
     218
     219      macdrop(ldshift)  macdrop(rdshift)
     220      end subr divmw;
     221 ..defenv_divmw
       1 .=member catmw
       2 .-defenv_catmw.
       3      subr catmw(ax, ay, at);                $  x .cc. y
       4      access ermwns;
       5
       6
       7      size  ax(szmax), ay(szmax), at(szmax);  $ arguments.
       8      size  ncinx(ps), nciny(ps), ncint(ps);  $ lengths of arguments.
       9      size  orgofx(ps), orgofy(ps), orgoft(ps);  $ origin values.
      10      size  i(ps);  $ loop index.
      11
      12 $    initialize some of the quantities defined in the size statement
      13 $    and check for well formed inputs x and y.  we permit an input
      14 $    string to have its leftmost character in the middle of a word.
      15 $    the output string will always be left adjusted to a word boundary.
      16 $    we assume that the compiler has sized t correctly (see little
      17 $    newsletter 27, page 13).  this takes great faith.
      18
      19      call vcsmw(ax, 15);  call vcsmw(ay, 16);
      20
      21      ncinx = slen ax;
      22      nciny = slen ay;
      23      ncint = ncinx + nciny;
      24      orgofx = sorg ax;
      25      orgofy = sorg ay;
      26
      27 $    create a descriptor for t (the result)
      28
      29      orgoft = .sds. ncint + 1;
      30      slen at = ncint;
      31      sorg at = orgoft;
      32
      33 $    move the characters from x to t, then from y to t
      34
      35      do i =  1 to  ncinx;
      36        orgofx = orgofx - cs;
      37        orgoft = orgoft - cs;
      38        .f. orgoft, cs, at = .f. orgofx, cs, ax;
      39        end do;
      40      do i =  1 to  nciny;
      41        orgofy = orgofy - cs;
      42        orgoft = orgoft - cs;
      43        .f. orgoft, cs, at = .f. orgofy, cs, ay;
      44        end do;
      45
      46      end subr catmw;
      47 ..defenv_catmw
      48
       1 .=member cinmw
       2 .-defenv_cinmw.
       3       fnct cinmw(ax, ay);                $  x .in. y
       4
       5
       6      size  ax(szmax), ay(szmax);  $ arguments.
       7      size  ncinx(ps), nciny(ps);  $ lengths of arguments.
       8      size  orgofx(ps), orgofy(ps);  $ origin values.
       9      size  i(ps);  $ loop index.
      10      size  howfar(ps);       $ max. character number for success.
      11      size  j(ps);            $ loop index.
      12      size  cinmw(ps);        $ function value.
      13      size  frstchar(cs);     $ first character of x.
      14
      15 $    initialize some of the quantities defined in the size statement
      16 $    and check for well formed inputs x and y.  we permit an input
      17 $    string to have its leftmost character in the middle of a word.
      18
      19      call vcsmw(ax, 17);  call vcsmw(ay, 18);
      20      ncinx = slen ax;
      21      nciny = slen ay;
      22      orgofx = sorg ax;
      23      orgofy = sorg ay;
      24
      25 $    initialize and check trivial case
      26
      27      cinmw = 0;
      28      if (ncinx > nciny) then
      29        return;
      30        end if;
      31
      32      if  ( (ncinx*nciny) = 0)  return;  $ quit if either null.
      33      orgofx = orgofx - cs;
      34      frstchar = .f. orgofx, cs, ax;
      35      ncinx = ncinx - 1;
      36      howfar = nciny - ncinx;
      37
      38      do i =  1 to  howfar;
      39        orgofy = orgofy - cs;
      40        if (frstchar = .f. orgofy, cs, ay) then
      41          do j =  1 to  ncinx;
      42            if (.f. orgofx-j*cs, cs, ax ^= .f. orgofy-j*cs, cs, ay)
      43              cont do i;
      44            end do;
      45          cinmw = i;
      46          return;
      47          end if;
      48        end do;
      49
      50      end fnct cinmw;
      51 ..defenv_cinmw
       1 .=member cexmw
       2 .-defenv_cexmw.
       3      subr cexmw(axarg, ayarg, az, at);        $  t = .s. x, y, z
       4      access ermwns;
       5
       6      size  axarg(ps), ax(ps);  $ starting position, and working copy.
       7      size  ayarg(ps), ay(ps);  $ length, and working copy.
       8      size  az(szmax), at(szmax);  $ source and target.
       9      size  ncinz(ps);        $ length of z.
      10      size  orgofz(ps);       $ origin of z.
      11      size  orgoft(ps);       $ origin of t.
      12      size  i(ps);            $ index.
      13 .+mwcc.  $    check for compiler error
      14      if (wt <= 0)
      15        then call errmw(-16);               $  bad argument to cexmw
      16        end if;
      17 ..mwcc
      18 $    initialize some of the quantities defined in the size statement
      19 $    and check for well formed input z.  we permit the first character
      20 $    of z to be in the middle of a word, but the output string t will
      21 $    always be left aligned on a word boundary.  we also check to be
      22 $    certain that t is big enough to hold the output string.
      23
      24      ncinz = slen az;
      25      orgofz = sorg az;
      26      ax = axarg;  ay = ayarg;
      27      call vcsmw(az, 22);
      28      if ax <= 0 then
      29        xopern=ax; call errmw(19); $  bad user arg 1 to cexmw
      30        end if;
      31      if ay < 0 then
      32        xopern=ay; call errmw(20); $  bad user arg 2 to cexmw
      33        end if;
      34      if  ax+ay-1 > ncinz  then
      35          xopern = ax+ay-1;  call errmw(21);  $ bad position
      36          end if;
      37      orgoft = .sds. ay + 1;
      38      sorg at = orgoft;
      39      slen at = ay;
      40
      41 $    move the characters from z to t
      42
      43      orgofz = orgofz - (ax - 1) * cs;
      44      do i =  1 to  ay;
      45        orgofz = orgofz - cs;
      46        orgoft = orgoft - cs;
      47        .f. orgoft, cs, at = .f. orgofz, cs, az;
      48        end do;
      49
      50      end subr cexmw;
      51 ..defenv_cexmw
       1 .=member casmw
       2 .-defenv_casmw.
       3      subr casmw(axarg, ayarg, az, at);       $  .s. x, y, t = z
       4      access ermwns;
       5
       6      size  axarg(ps), ax(ps);  $ starting position, and working copy.
       7      size  ayarg(ps), ay(ps);  $ length, and working copy.
       8      size  az(szmax), at(szmax);  $ source and target.
       9      size  ncint(ps);        $ length of t.
      10      size  ncinz(ps);        $ length of z.
      11      size  orgofz(ps);       $ origin of z.
      12      size  orgoft(ps);       $ origin of t.
      13      size  i(ps);            $ index.
      14
      15      ax = axarg;  ay = ayarg;
      16
      17 $    initialize some of the quantities defined in the size statement
      18 $    and check for well formed strings z and t.  we permit a string to
      19 $    have its first (leftmost) character in the middle of a word.
      20
      21      call vcsmw(az, 25);
      22      call vcsmw(at, 26);
      23      ncinz = slen az;
      24      ncint = slen at;
      25      orgofz = sorg az;
      26      orgoft = sorg at;
      27
      28 $    check user arguments x and y for consistency with target string t
      29
      30      if  ax <= 0  then
      31          xopern=ax; call errmw(23); $  bad user arg 1 to casmw
      32          end if;
      33      if  ay < 0  then
      34          xopern=ay; call errmw(24); $  bad user arg 2 to casmw
      35          end if;
      36      if  ax+ay-1 > ncint  then
      37          xopern = ax+ay-1;  call errmw(27);  $ bad position
      38          end if;                               $  of arguments to casmw
      39
      40 $    move characters one through y of string z into characters x
      41 $    through x + y - 1 of string t.  if string z is shorter than
      42 $    y characters, move blanks as needed into t.
      43
      44      orgoft = orgoft - (ax - 1) * cs;
      45      do i =  1 to  ay;
      46        orgoft = orgoft - cs;
      47        if (i <= ncinz)
      48          then orgofz = orgofz - cs;
      49          .f. orgoft, cs, at = .f. orgofz, cs, az;
      50            else .f. orgoft, cs, at = 1r ;
      51          end if;
      52        end do;
      53
      54      end subr casmw;
      55 ..defenv_casmw
       1 .=member ceqmw
       2 .-defenv_ceqmw.
       3      fnct  ceqmw(ax, ay);  $ test strings for equality
       4      size  ax(ws+1), ay(ws+1);  $ strings to compare
       5      size  ceqmw(1);         $ result.
       6      size  px(ps), py(ps), lx(ps), ly(ps), seqmw(1);
       7      size  i(ps);
       8      ceqmw = 0;  $ assume unequal
       9      call vcsmw(ax, 31);  call vcsmw(ay, 31);
      10      lx = slen ax;  ly = slen ay;  $ get lengths
      11      if(lx ^= ly) return;  $ quit if lengths differ
      12      px = sorg ax;  py = sorg ay;  $ and origins
      13      do i = 1 to lx;  $ compare characters in turn
      14          px = px-cs;  py = py-cs;  $ advance to next char
      15          if( .f. px,cs,ax ^= .f. py, cs, ay)  return;
      16          end do;
      17      ceqmw = 1;  $ they agree
      18      end fnct ceqmw;
      19 ..defenv_ceqmw
      20 .-defenv_vcsmw.
       1 .=member vcsmw
       2      subr vcsmw(ax, ernum);  $ verify character string structure.
       3      access ermwns;
       4      $   verify that argument has form of character string.
dsu   21      size  ax(ws+1);         $ character string.
       6      size  ernum(ps);        $ error number.
       7      size  ncinx(ps);        $ length.
       8      size  orgofx(ps);       $ origin.
       9      size  remofx(ps);       $ remaining characters.
      10
      11      ncinx = slen ax;
      12      if  (ncinx=0) return;  $ null string always ok.
      13      orgofx = sorg ax;
      14      remofx = orgofx - (ncinx * cs + ldcs + 1);
      15      if  orgofx < ldcs ! remofx < 0
      16          ! (((remofx/cs) * cs) ^= remofx)  then
      17          call ersmw(ax);  call errmw(ernum);
      18          end if;
      19      end subr vcsmw;
      20 ..defenv_vcsmw
       1 .=member endmul
       1 .=member ltlterm
       3      +*  phasemax = 3 **  $ number phases.
       4
dsb   70 .+s66.
       6
       7      subr ltlterm;           $ terminate compiler overlay phase.
       8      nameset lexcard;        $ lex reports line total here.
       9      size  lines(ps);        $ total input lines.
      10      end nameset;
      11      size  phase(ps);  data phase=0;  $ compilation phase.
      12      real  timetot, phasetime;  dims phasetime(phasemax+1);
      13      size  etime(ws);        $ elapsed time in milliseconds.
      14      size  lcs(ps);          $ nonzero to list compilation statistics.
      15      size  i(ps);            $ loop index.
      16
      17      phase = phase + 1;
      18      call letime(etime);
      19      phasetime(phase) = float(etime) / 1000.0;
      20      if  (phase<=phasemax)  go to ret;
      21      call getipp(lcs, 'lcs=1/0');
      22      if  (lcs=0)  go to ret;
      23      $   convert times to elapsed times in phases.
      24      timetot = phasetime(phasemax+1) - phasetime(1);
      25      do  i = phasemax+1 to 2 by -1;
      26          phasetime(i) = phasetime(i) - phasetime(i-1);
      27          end do;
      28      if  (timetot<=0.0)  go to ret;  $ if timer failure.
      29
dsb   71          $  use lcp to avoid loading most of io.
      45      endl  endl  textl('compilation statistics: ')
      46      intlp(lines,7)  textl(' lines in ')
      47      intlp(ifix(timetot*1000.0),9)
      48      textl(' milliseconds at rate of ')
      49      intlp( ifix( 60.0 * float(lines) / timetot) , 7)
      50      textl(' lines per minute.')
      51      endl  textl('phase times:')
      52      do  i = 1 to phasemax;
      53          intlp(ifix( 1000.0*phasetime(i+1) ),7)
      54          end do;
      55      endl  textl('end of compilation.')  endl
      57 /ret/
      58      call ltlovl;  $ invoke overlay executive.
      59      end subr ltlterm;
dsba   1 ..s66
      60 .+s37.
      61      subr  ltlterm(phase, rc);  $ terminate a compiler phase.
      62      size  phase(ps);   $ phase just completed.
      63      size  rc(ps);    $ return code from that phase.
      64
      65      call ltlfin(0, phase*4b'1000000'+rc);   $ success with 'funny' rc.
      66
      67      end subr ltlterm;
      68 ..s37
utsa 143 .+s47.
utsa 144      subr  ltlterm(phase, rc);  $ terminate a compiler phase.
utsa 145      size  phase(ps);   $ phase just completed.
utsa 146      size  rc(ps);    $ return code from that phase.
utsa 147
utsa 148      call ltlfin(0, phase*4b'1000000'+rc);   $ success with 'funny' rc.
utsa 149
utsa 150      end subr ltlterm;
utsa 151 ..s47
dsb   73 .+s10.
dsb   74      subr  ltlterm(phase, rc);   $ end compiler phase.
dsb   75      size  phase(ps);   $ phase terminated.
dsb   76      size  rc(ps);   $ return code.
dsb   77
dsb   78      call ltlfin(0, rc);   $ end phase.
dsb   79
dsb   80      end subr ltlterm;
dsb   81 ..s10
vax   67 .+s32.
vax   68      subr  ltlterm(phase, rc);   $ end compiler phase.
vax   69      size  phase(ps);   $ phase terminated.
vax   70      size  rc(ps);   $ return code.
vax   71
vax   72      call ltlfin(0, rc);   $ end phase.
vax   73
vax   74      end subr ltlterm;
vax   75 ..s32
       1 .=member sier11
       2 .+s11.
       3
       4      subr  ltlsierr(n, fn);        $ error printing routine for -sio-.
       5      $   this routine prints the error messages generated by the little
       6      $   io interface.
       7      size  n(ps);                  $ error message number.
       8      size  fn(ps);                 $ current file number at time of err
       9      size  i(ps);                  $ temporary.
      10
      11
      12      $    if this is a recursive error, just terminate the program.
      13      if  sioerflg then $ this is a recursive call.
      14          call  ltlfin(1, 4001);  $ abnormally end this program.
      15          end if;
      16
      17      sioerflg = yes;  $ indicate that program is being terminated.
      18 $    call  ltlxtrs;  $ set trace back chain.
      19      endl  textl('error ')  intl(n)  textl('  file')  intl(fn)  textl('
      20      if  n=32 ^ n>8 ^ n<1 then  $ bad error.
      21          textl('invalid error number #')
      22          go to ret;  $ go to common end processing.
      23      else  $ error is ok.
      24          go to e(n) in 1 to 8;
      25          end if;
      26
      27      +*  er(n, msg) = /e(n)/  textl(msg)  go to ret;  **
      28
      29      er(1, 'file already connected')
      30      er(2, 'unformatted request to formatted file')
      31      er(3, 'formatted request to unformatted file')
      32      er(4, 'wrong access type')
      33      er(5, 'file already opened')
      34      er(6, 'out of buffers')
      35      er(7, 'unsupported function')
      36      er(8, 'illegal filename')
      37
      38 /ret/  $ common return processing.
      39      textl('.')  endl   endl   endl
      40      sioerflg = no;  $ show processing done.
      41      call  ltlfin(1, 2100+n);  $ call termination routine.
      42      end subr ltlsierr;
      43 ..s11
« July 2022 »
Su Mo Tu We Th Fr Sa
1 2
3 4 5 6 7 8 9
10 11 12 13 14 15 16
17 18 19 20 21 22 23
24 25 26 27 28 29 30
31
 

Powered by Plone CMS, the Open Source Content Management System

This site conforms to the following standards: